COMPILATION LISTING OF SEGMENT lisp_garbage_collector_ Compiled by: Multics PL/I Compiler, Release 33e, of October 6, 1992 Compiled at: CGI Compiled on: 2000-04-18_1123.18_Tue_mdt Options: optimize map 1 /* ************************************************************** 2* * * 3* * Copyright, (C) Massachusetts Institute of Technology, 1973 * 4* * * 5* ************************************************************** */ 6 lisp_garbage_collector_: proc; 7 8 dcl curtop fixed bin(18), 9 total_allocation fixed bin(34), 10 old_allocation fixed bin(34), 11 lisp_gc_alm_$collect entry(bit(1)aligned) returns(ptr), 12 lisp_io_control_$gc_flush entry(ptr), 13 new_seg ptr, 14 curseg ptr, 15 segment_chain based ptr aligned, 16 lisp_static_vars_$gc_mark_bits bit(18) aligned external, 17 oldgcmark bit(18) aligned defined lisp_static_vars_$gc_mark_bits, 18 curgcmark bit(18) aligned, 19 chaser ptr, 20 ungclist_ptr ptr init(null()), 21 ungc_element fixed bin(71) aligned based, 22 1 ungclist_element based aligned like obarray_list_element, 23 24 obarray_list ptr init(null()), 25 obarray_list_end ptr init(null()), 26 obarray_ptr ptr, 27 last ptr, 28 tempp ptr, 29 copy_nil fixed bin(71), 30 gcmode fixed bin init(-1), /* set to Obarray_array if in gctwa mode */ 31 atptr ptr, 32 lisp_static_vars_$status_gctwa external fixed bin(71) aligned, 33 lisp_fault_handler_$nointerrupt entry, 34 1 obarray_list_element based aligned, 35 2 next ptr, 36 2 current ptr, 37 old_array_stcd_instruction bit(36) static init("001000000000001000011101111001000000"b), 38 1 Obarray based aligned, 39 2 bucket(0:510) aligned pointer, 40 2 char_atom(0:127) fixed bin(71), 41 42 1 copied_string based aligned, 43 2 pad5050 fixed bin, 44 2 new_address ptr unaligned, 45 reti fixed bin, 46 arg fixed bin(71) aligned, 47 1 arg_ovly based (addr(arg)) aligned, 48 2 pad bit(53) unal, 49 2 arg_points_at_odd_addr bit(1) unal, 50 2 rest bit(18) unal, 51 allocptr ptr, 52 workptr ptr, 53 lisp_static_vars_$garbage_collected_ptrs ext fixed bin(71), 54 lisp_static_vars_$number_gc_ptrs ext fixed bin(17) aligned, 55 bottom_ptr ptr, 56 size fixed bin, 57 stack ptr, 58 gc_mark fixed bin(71) static init(-1), 59 left fixed bin, 60 idx fixed bin, 61 copy_words (size) fixed bin(35) aligned based, 62 hcs_$truncate_seg entry(ptr, fixed bin, fixed bin(35)), 63 lisp_segment_manager_$get_lists entry(ptr), 64 lisp_segment_manager_$free_lists entry(ptr), 65 ioa_ entry options(variable), 66 ioa_$ioa_stream_nnl entry options(variable), 67 lisp_print_$type_string entry(char(*)), 68 virtual_cpu_time_ entry returns(fixed bin(52)), 69 start_time fixed bin(52), 70 saved_alloc_fault_word bit(36), 71 lisp_alloc_$get_fault_word entry(bit(36)), 72 lisp_alloc_$rehash_maknum entry, 73 lisp_default_handler_$deferred_quit entry, 74 fault_bits bit(36) aligned, 75 lisp_default_handler_$alloc_fault entry ( bit(36) aligned ), 76 (lisp_special_fns_$cons, lisp_special_fns_$list, 77 lisp_special_fns_$ncons, lisp_$apply, lisp_$eval) entry, 78 lisp_static_vars_$garbage_collect_inhibit bit(36) aligned external, 79 old_segs ptr, 80 meter_time float bin(63), 81 lisp_static_vars_$i_am_gcing bit(1) aligned external, 82 lisp_static_vars_$gcmax fixed bin(35) external, 83 lisp_static_vars_$space_names_atom external pointer, 84 lisp_static_vars_$gc_time external static fixed bin(71), 85 gc_time fixed bin(71), 86 Maximum_Reasonable_Size fixed bin(18) static init(65000), /* no atom bigger than this */ 87 com_err_ entry options(variable), 88 (addr,addrel,ptr,divide,null,mod,hbound,baseno,binary,bit,float,rel,lbound,string,fixed) builtin; 89 90 dcl lisp_static_vars_$cleanup_list fixed bin(71) external, 91 lisp_static_vars_$cleanup_list_exists bit(1) aligned external, 92 lisp_static_vars_$gc_unwinder_kludge label external, 93 lisp_static_vars_$activate_gc_unwinder_kludge bit(1) aligned external; 94 95 dcl 1 argo aligned based(addr(arg)->based_ptr), /* overlay for bug messages */ 96 2 (w1, w2, w3, w4, w5, w6) bit(36) aligned; 97 98 1 1 /* Include file describing the data related to the free storage allocation package */ 1 2 1 3 dcl lisp_alloc_$alloc_fault_word ext bit(36) aligned, 1 4 alloc_fault_word bit(36) defined ( lisp_alloc_$alloc_fault_word), 1 5 lisp_alloc_$alloc_info bit(288) aligned ext, /* info to save for recursiveness of lisp */ 1 6 1 7 /* FAULT BIT MASKS FOR FAULT BITS IN ALLOC_FAULT_WORD 1 8* THE FAULT CODES ARE: 1 9* 6 ft3 - car or cdr of number 1 10* 5 mme4 - array oob 1 11* 4 quit 1 12* 2 alrm 1 13* 1 cput 1 14* */ 1 15 1 16 1 17 quit_fault bit(36) static init ("000000000000000000000000000000000100"b), 1 18 alrm_fault bit(36) static init ("000000000000000000000000000000000010"b), 1 19 cput_fault bit(36) static init ("000000000000000000000000000000000001"b), 1 20 1 21 fault_mask bit(36) static init ("000000000000000000000000000000000111"b), 1 22 lisp_alloc_$gc_blk_cntr ext fixed bin, /* number of 16k blocks before next gc. */ 1 23 lisp_alloc_$seg_blk_cntr ext fixed bin, /* number of 16k blocks to end of segment */ 1 24 lisp_alloc_$consptr ext ptr aligned, /* pointer to ad tally word */ 1 25 1 consptr_ovly based (addr(lisp_alloc_$consptr)) aligned, /* overlay to set further modification field of pointer */ 1 26 2 padding bit(66) unal, 1 27 2 mod bit(6) unal, 1 28 lisp_alloc_$cur_seg ext ptr aligned, /* pointer to current allocation segment */ 1 29 1 30 1 alloc_segment based aligned, /* structure of a free storage segment */ 1 31 2 next_seg ptr, /* chain to next older segment */ 1 32 2 tally_word, /* ad tally word */ 1 33 3 seg_offset bit(18) unal, /* next address in this seg to be allocated */ 1 34 3 tally bit(12) unal, /* decremented once for every 4 words, 16k runout */ 1 35 3 delta fixed bin(5) unal, /* should be set to 4, the size of a cons */ 1 36 2 pad bit(36), 1 37 2 first_allocatable_word bit(72); 1 38 1 39 /* end include file describing free storage structure */ 99 2 1 /***** BEGIN INCLUDE FILE lisp_array_fmt.incl.pl1 *****/ 2 2 2 3 /* This include file defines the format of the "new" LISP arrays. 2 4* Written 74.05.13 by DAM */ 2 5 2 6 /* Info block in static space. pointed at by array ptr */ 2 7 2 8 dcl 1 array_info aligned based structure, /* 8 words long */ 2 9 2 ndims fixed bin(17) unaligned, /* number of dimensions */ 2 10 2 gc_mark bit(18) unaligned, /* alternating bits for garbage coll. */ 2 11 2 call_array_operator bit(36), /* tspbp instruction to array opr */ 2 12 2 array_data_ptr pointer, /* -> array_data structure */ 2 13 2 array_load_sequence(3) bit(36), /* lda, ldq, tra bp|0 */ 2 14 2 type fixed bin(17) unaligned, /* type of array, see dcl below */ 2 15 2 minus_2_times_ndims fixed bin(17) unaligned; /* for convenience of array opr */ 2 16 2 17 /* Codes for the different types of arrays: 2 18* Name Value arg to *array to create one */ 2 19 2 20 dcl (S_expr_array init(0), /* t */ 2 21 Un_gc_array init(1), /* nil */ 2 22 Fixnum_array init(2), /* fixnum */ 2 23 Flonum_array init(3), /* flonum */ 2 24 Readtable_array init(4), /* readtable */ 2 25 Obarray_array init(5), /* obarray */ 2 26 Dead_array init(6) /* (*rearray a) */ 2 27 ) fixed bin(17) static; 2 28 2 29 /* Block of array data and dimensions, in garbage-collected Lists space */ 2 30 2 31 dcl 1 array_data aligned based structure, 2 32 2 dope_vector(ZERO), /* address by dope_vector(i-ndims). no way to dcl in PL/I */ 2 33 3 bounds fixed bin(35), /* 0 <_ subscript < bounds */ 2 34 3 multiplier fixed bin(35), /* multiplier in polynomial-type subscript calc. */ 2 35 2 data(0:1000) fixed bin(71); /* single or double words depending on type of array */ 2 36 2 37 dcl ZERO fixed bin static init(0); /* Circumvent a compiler bug causing reference through null pointer in get_array_size$multf */ 2 38 2 39 /***** END INCLUDE FILE lisp_array_fmt.incl.pl1 *****/ 100 3 1 /* BEGIN INCLUDE FILE lisp_iochan.incl.pl1 */ 3 2 3 3 /* This include file describes the format of the 'iochan' block, 3 4* which is used to implement lisp file-objects. The iochan 3 5* is the central data base of the i/o system. When open 3 6* is used, an iochan is created in lisp static storage. 3 7* When the lisp environment is booted, 2 iochans for input and 3 8* output on the tty are created. Iochans are saved and restored 3 9* by the save mechanism */ 3 10 3 11 /* open i/o channel information */ 3 12 3 13 dcl 1 iochan based aligned, /* format of a file object */ 3 14 2 ioindex fixed bin(24), /* 0-origin character position in block */ 3 15 2 iolength fixed bin(24), /* size of block in chars - actual(in), max(out) */ 3 16 2 ioptr pointer, /* -> block */ 3 17 2 thread pointer, /* list of all iochans open; from lisp_static_vars_$iochan_list */ 3 18 2 fcbp pointer, /* for tssi_ */ 3 19 2 aclinfop pointer, /* .. */ 3 20 2 component fixed bin, /* .. */ 3 21 2 charpos fixed bin, /* 0-origin horizontal position on line */ 3 22 2 linel fixed bin, /* (out) line length, 0 => oo */ 3 23 2 flags unaligned, 3 24 3 seg bit(1), /* 1 => msf, 0 => stream */ 3 25 3 read bit(1), /* 0 => openi, 1 => not */ 3 26 3 write bit(1), /* 0 => openo, 1 => not */ 3 27 3 gc_mark bit(1), /* for use by the garbage collector */ 3 28 3 interactive bit(1), /* 1 => input => this is the tty 3 29* output => flush buff after each op */ 3 30 3 must_reopen bit(1), /* 1 => has been saved and not reopend yet */ 3 31 3 nlsync bit(1), /* 1 => there is a NL in the buffer (output streams only) */ 3 32 3 charmode bit(1), /* enables instant ios_$write */ 3 33 3 extra_nl_done bit(1), /* 1 => last char output was extra NL for chrct */ 3 34 3 fixnum_mode bit(1), /* to be used with in and out functions */ 3 35 3 image_mode bit(1), /* just suppresses auto-cr */ 3 36 3 not_yet_used bit(25), 3 37 2 function fixed bin(71), /* EOF function (input), or endpagefn (output) <<< gc-able >>> */ 3 38 2 namelist fixed bin(71), /* list of names, car is directory pathname <<< gc-able >>> */ 3 39 2 name char(32) unaligned, /* stream name or entry name */ 3 40 2 pagel fixed bin, /* number of lines per page */ 3 41 2 linenum fixed bin, /* current line number, starting from 0 */ 3 42 2 pagenum fixed bin, /* current page number, starting from 0 */ 3 43 3 44 flag_reset_mask bit(36) aligned static init( /* anded into flags with each char */ 3 45 "111011110111111111"b); 3 46 3 47 /* END INCLUDE FILE lisp_iochan.incl.pl1 */ 101 4 1 /* lisp number format -- overlaid on standard its pointer. */ 4 2 4 3 4 4 dcl 1 fixnum_fmt based aligned, 4 5 2 type_info bit(36) aligned, 4 6 2 fixedb fixed bin, 4 7 4 8 1 flonum_fmt based aligned, 4 9 2 type_info bit(36) aligned, 4 10 2 floatb float bin, 4 11 4 12 fixnum_type bit(36) aligned static init("000000000000000000000100000000100111"b), 4 13 flonum_type bit(36) aligned static init("000000000000000000000010000000100111"b); 4 14 4 15 /* end of lisp number format */ 4 16 102 5 1 /* Include file lisp_ptr_fmt.incl.pl1; 5 2* describes the format of lisp pointers as 5 3* a bit string overlay on the double word ITS pair 5 4* which allows lisp to access some unused bits in 5 5* the standard ITS pointer format. It should be noted that 5 6* this is somewhat of a kludge, since 5 7* it is quite machine dependent. However, to store type 5 8* fields in the pointer, saves 2 words in each cons, 5 9* plus some efficiency problems. 5 10* 5 11* D.Reed 4/1/71 */ 5 12 /* modified to move type field to other half of ptr */ 5 13 /* D.Reed 5/31/72 */ 5 14 5 15 5 16 dcl based_ptr ptr aligned based; /* for dealing with lisp values as pointers */ 5 17 dcl lisp_ptr_type bit(36) aligned based, /* for more efficient checking of type bits */ 5 18 1 lisp_ptr based aligned, /* structure of double word pointer in lisp */ 5 19 2 segno bit(18) unaligned, /* segment number pointed to by pointer */ 5 20 2 ringnum bit(3) unaligned, /* ring mumber for validation */ 5 21 2 type bit(9) unaligned, /* type field */ 5 22 2 itsmod bit(6) unaligned, 5 23 2 offset fixed bin(17) unaligned, /* offset in segment of object pointed to */ 5 24 2 chain bit(18) unaligned, /* normally 0, but may be set to chain pointers together */ 5 25 5 26 /* manifest constant strings for testing above type field */ 5 27 5 28 ( 5 29 Cons init("000000000"b), /* a pointer to a list has a zero type field */ 5 30 Fixed init("100000000"b), /* a fixed point number, stored in second word of the ptr */ 5 31 Float init("010000000"b), /* a floating number, also stored in the second word of the ptr */ 5 32 Atsym init("001000000"b), /* this bit on means a ptr to an atomic symbol */ 5 33 Atomic init("111111111"b), /* any bit on means an atomic data type */ 5 34 Bignum init("000001000"b), /* a multiple-precision number */ 5 35 Bigfix init("000001000"b), /* a fixed point bignum (only kind for now) */ 5 36 Numeric init("110000000"b), /* either type immediate number. Both bits on 5 37* means a special internal uncollectable weird object */ 5 38 Uncollectable init("110000000"b), /* not looked through by garbage collector */ 5 39 String init("000100000"b), /* pointer to lisp character string - length word, chars */ 5 40 Subr init("000010000"b), /* pointer to compiled (or builtin) subroutine (linkage) code */ 5 41 System_Subr init("000000100"b), /* Subr bit must be on too, indicates ptr into lisp_subr_tv_ */ 5 42 Array init("000000010"b), /* Subr bit must be on too, indicates ptr to a lisp array */ 5 43 File init("000000001"b) /* pointer to a file object (iochan block) */ 5 44 ) bit(9) static, 5 45 5 46 /* 36 bit manifest constant strings for testing lisp_ptr_type */ 5 47 5 48 5 49 ( 5 50 Cons36 init("000000000000000000000000000000"b), 5 51 Fixed36 init("000000000000000000000100000000"b), 5 52 Float36 init("000000000000000000000010000000"b), 5 53 Atsym36 init("000000000000000000000001000000"b), 5 54 Atomic36 init("000000000000000000000111111100"b), 5 55 Bignum36 init("000000000000000000000000001000"b), 5 56 System_Subr36 5 57 init("000000000000000000000000000100"b), 5 58 Bigfix36 init("000000000000000000000000001000"b), 5 59 Numeric36 init("000000000000000000000110000000"b), /* does not check for bignum */ 5 60 NotConsOrAtsym36 5 61 init("000000000000000000000110111111"b), 5 62 SubrNumeric36 5 63 init("000000000000000000000110010000"b), /* used in garbage collector, for quick check */ 5 64 String36 init("000000000000000000000000100000"b), 5 65 Subr36 init("000000000000000000000000010000"b), 5 66 File36 init("000000000000000000000000000001"b), 5 67 Array36 init("000000000000000000000000000010"b)) bit(36) aligned static, 5 68 5 69 /* undefined pointer value is double word of zeros */ 5 70 5 71 Undefined bit(72) static init(""b); 5 72 5 73 /* end of include file lisp_ptr_fmt.incl.pl1 */ 103 6 1 /* lisp stack header format */ 6 2 /* Last modified 7/21/72 by Reed for in_pl1 flag */ 6 3 /* Modified 1978 by Greenberg for unwind-protect ops */ 6 4 6 5 declare 6 6 6 7 1 stack_seg based aligned, /* stored in base of unmkd_pdl segment */ 6 8 2 marked_stack_bottom ptr, /* where marked stack begins... */ 6 9 2 unmkd_stack_bottom ptr, /* where unmkd_ stack actually starts */ 6 10 2 stack_ptr_ptr ptr, /* points at lisp_static_vars_$stack_ptr */ 6 11 2 unmkd_ptr_ptr ptr, /* points at lisp_static_vars_$unmkd_ptr's offset word */ 6 12 2 array_pointer ptr, /* obsolete */ 6 13 2 nil fixed bin(71), /* object for nil */ 6 14 2 true fixed bin(71), /* object for t */ 6 15 2 in_pl1_code bit(36), /* flag indicating that we are in pl1 code if non-zero */ 6 16 2 padding0 bit(36), /* double word boundary preservation */ 6 17 2 bind_op ptr, /* pointers to operators for run-time support */ 6 18 2 unbind_op ptr, 6 19 2 errset1_op ptr, 6 20 2 errset2_op ptr, 6 21 2 unerrset_op ptr, 6 22 2 call_op ptr, 6 23 2 catch1_op ptr, 6 24 2 catch2_op ptr, 6 25 2 uncatch_op ptr, 6 26 2 gensym_data (2) bit(36) aligned, /* stuff used by the gensym function */ 6 27 2 system_lp ptr, /* pointer to the system's linkage section */ 6 28 2 iogbind_op ptr, 6 29 2 unseen_go_tag_op ptr, 6 30 2 throw1_op ptr, 6 31 2 throw2_op ptr, 6 32 2 signp_op ptr, 6 33 2 type_fields bit(72) aligned, /* fixnum, flonum type for compiled code */ 6 34 2 return_op ptr, 6 35 2 err_op ptr, 6 36 2 pl1_interface ptr, /* pointer to pl1 interface for type 2 subrs. */ 6 37 2 pl1_lsubr_interface ptr, /* same for type -2 subrs */ 6 38 2 cons_opr ptr, /* cons operator */ 6 39 2 ncons_opr ptr, /* ncons operator */ 6 40 2 xcons_opr ptr, /* xcons operator */ 6 41 2 begin_list_opr ptr, /* operator to make initial cell of list */ 6 42 2 append_list_opr ptr, /* operator to append to last-made cell of list */ 6 43 2 terminate_list_opr ptr, /* opeator to append last cell to next to last cell of list */ 6 44 2 compare_op ptr, /* fixnum/flonum comparison operator */ 6 45 2 link_op ptr, 6 46 2 array_operator pointer, /* accessing operator, invoked by arrays */ 6 47 2 dead_array_operator pointer, /* dead arrays invoke this operator instead */ 6 48 2 store_operator pointer, /* operator to do compiled store */ 6 49 2 floating_store_operator pointer, /* ditto, but operand is in EAQ */ 6 50 2 array_info_for_store pointer, /* -> array_info block of last array referenced */ 6 51 2 array_offset_for_store fixed bin(18), /* offset in array_data block of last array element referenced */ 6 52 2 padding bit(36), 6 53 2 array_link_snap_opr pointer, 6 54 2 create_string_desc_op ptr, 6 55 2 create_array_desc_op ptr, 6 56 2 pl1_call_op ptr, 6 57 2 cons_string_op ptr, 6 58 2 create_varying_string_op ptr, 6 59 2 unwp1_op ptr, 6 60 2 unwp2_op ptr, 6 61 2 ununwp_op ptr, 6 62 2 irest_return_op ptr, 6 63 2 pl1_call_nopop_op ptr, 6 64 2 rcv_char_star_op ptr, 6 65 2 spare2 (7) ptr, 6 66 2 begin_unmkd_stack(16325) fixed bin(71); /* rest of segment is the unmarked pdl */ 6 67 6 68 dcl call_array_operator bit(36) static init("100112273120"b3), /* tspbb ab|112,* */ 6 69 call_dead_array_operator bit(36) static init("100114273120"b3); /* tspbb ab|114,* */ 6 70 6 71 /* end stack segment format */ 104 7 1 /***** BEGIN INCLUDE FILE lisp_string_fmt.incl.pl1 ***** 7 2* describes format of storage for lisp 7 3* character strings. 7 4* D. Reed 4/1/71 */ 7 5 7 6 dcl 1 lisp_string based aligned, 7 7 2 string_length fixed bin, 7 8 2 string char(1 refer(string_length)); 7 9 7 10 /***** END INCLUDE FILE lisp_string_fmt.incl.pl1 */ 105 8 1 /* Include file lisp_bignum_fmt.incl.pl1 */ 8 2 8 3 dcl 1 lisp_bignum based aligned, /* structure describing lisp big number */ 8 4 2 sign bit(18) unaligned, /* either all ones, or all zeros */ 8 5 2 prec fixed bin(17) unaligned, /* number of words in this number's precision */ 8 6 2 words(0 refer(lisp_bignum.prec)) fixed bin(35); /* 35 significant bits per word. */ 8 7 8 8 /* End include file lisp_bognum_fmt.incl.pl1 */ 106 9 1 /* include file lisp_stack_fmt.incl.pl1 -- 9 2* describes the format of the pushdown list 9 3* used by the lisp evaluator and lisp subrs 9 4* for passing arguments, saving atom bindings, 9 5* and as temporaries */ 9 6 9 7 dcl 9 8 temp(10000) fixed bin(71) aligned based, 9 9 9 10 temp_ptr(10000) ptr aligned based, 9 11 1 push_down_list_ptr_types(10000) based aligned, 9 12 2 junk bit(21) unaligned, 9 13 2 temp_type bit(9) unaligned, 9 14 2 more_junk bit(42) unaligned, 9 15 9 16 1 pdl_ptr_types36(10000) based aligned, 9 17 2 temp_type36 bit(36), 9 18 2 junk bit(36), 9 19 9 20 1 binding_block aligned based, 9 21 2 top_block bit(18) unaligned, 9 22 2 bot_block bit(18) unaligned, /* these two are rel pointers into the marked PDL */ 9 23 2 back_ptr bit(18) unaligned, /* relative pointer into unmarked PDL for last binding block. */ 9 24 2 rev_ptr bit(18) unaligned, /* relative pointer to reversal bb which reversed this one, init to 0 */ 9 25 9 26 1 bindings(10000) based aligned, /* format fof bindings on stack */ 9 27 2 old_val fixed bin(71) aligned, 9 28 2 atom fixed bin(71) aligned; 9 29 9 30 9 31 9 32 /* end include file lisp_stack_fmt.incl.pl1 */ 107 10 1 /* Include file lisp_common_vars.incl.pl1; 10 2* describes the external static variables which may be referenced 10 3* by lisp routines. 10 4* D. Reed 4/1/71 */ 10 5 10 6 dcl 1 lisp_static_vars_$lisp_static_vars_ external, 10 7 2 cclist_ptr ptr, /* pointer to list of constants kept 10 8* by compiled programs */ 10 9 2 garbage_collect_soon bit(1) aligned, /* if this is on we should garbage collect soon */ 10 10 10 11 lisp_static_vars_$err_recp ptr ext aligned, /* pointer to error data */ 10 12 err_recp ptr defined (lisp_static_vars_$err_recp), 10 13 eval_frame ptr defined (lisp_static_vars_$eval_frame), /* info kept by eval if *rset t */ 10 14 lisp_static_vars_$eval_frame ptr ext static, 10 15 lisp_static_vars_$prog_frame ptr ext aligned, 10 16 lisp_static_vars_$err_frame ptr ext aligned, 10 17 lisp_static_vars_$catch_frame ptr ext aligned, 10 18 lisp_static_vars_$unwp_frame ptr ext aligned, 10 19 lisp_static_vars_$stack_ptr ptr ext aligned, 10 20 lisp_static_vars_$t_atom fixed bin(71) ext aligned, 10 21 lisp_static_vars_$top_level label ext, /* top level read_eval_print loop */ 10 22 lisp_static_vars_$unmkd_ptr ptr ext aligned, 10 23 lisp_static_vars_$binding_top ptr ext aligned, 10 24 lisp_static_vars_$obarray fixed bin(71) aligned ext, 10 25 obarray fixed bin(71) defined (lisp_static_vars_$obarray), 10 26 lisp_static_vars_$array_atom fixed bin(71) aligned ext, 10 27 array_atom fixed bin(71) defined (lisp_static_vars_$array_atom), 10 28 binding_top ptr defined (lisp_static_vars_$binding_top), 10 29 unmkd_ptr ptr defined (lisp_static_vars_$unmkd_ptr), 10 30 stack_ptr ptr defined (lisp_static_vars_$stack_ptr), 10 31 lisp_static_vars_$nil ext static fixed bin(71) aligned, 10 32 nil fixed bin(71) defined (lisp_static_vars_$nil), 10 33 lisp_static_vars_$tty_input_chan ext static ptr, /* used by the reader */ 10 34 lisp_static_vars_$tty_output_chan ext static ptr, /*used by print*/ 10 35 tty_input_chan ptr def (lisp_static_vars_$tty_input_chan), 10 36 tty_output_chan ptr def (lisp_static_vars_$tty_output_chan), 10 37 lisp_static_vars_$iochan_list external pointer, /* list of all open iochans */ 10 38 nil_ptr ptr based(addr(lisp_static_vars_$nil)) aligned, 10 39 prog_frame ptr def (lisp_static_vars_$prog_frame), /* 3 ptrs for use of lisp_prog_fns_ */ 10 40 err_frame ptr def (lisp_static_vars_$err_frame), /* they point out frames in unmkd pdl */ 10 41 catch_frame ptr def (lisp_static_vars_$catch_frame), 10 42 unwp_frame ptr def (lisp_static_vars_$unwp_frame), 10 43 t_atom_ptr ptr aligned based(addr(lisp_static_vars_$t_atom)), 10 44 t_atom fixed bin(71) defined (lisp_static_vars_$t_atom); /* pointer to atom t */ 10 45 dcl lisp_static_vars_$user_intr_array(20) fixed bin(71) aligned ext static, /* -> atoms whose values are intr service functions */ 10 46 user_intr_array (20) fixed bin(71) aligned def (lisp_static_vars_$user_intr_array), 10 47 lisp_static_vars_$star_rset fixed bin(71) aligned ext static, 10 48 star_rset fixed bin(71) aligned def (lisp_static_vars_$star_rset); 10 49 10 50 10 51 /* end include file lisp_common_vars.incl.pl1 */ 108 11 1 /* Include file lisp_atom_fmt.incl.pl1; 11 2* describes internal format of atoms in the lisp system 11 3* D.Reed 4/1/71 */ 11 4 11 5 dcl 1 atom aligned based, /* overlay for atom fomat */ 11 6 2 value fixed bin(71), /* atom's value */ 11 7 2 plist fixed bin(71), /* property list */ 11 8 2 pnamel fixed bin, /* length of print name */ 11 9 2 pname char(1 refer(pnamel)), /* print name of atom */ 11 10 11 11 1 atom_ptrs based aligned, /* for use of plist and value of atom as ptrs */ 11 12 2 value ptr, 11 13 2 plist ptr, 11 14 11 15 1 atom_double_words based aligned, /* overlay for atom pointer checking */ 11 16 2 value bit(72), 11 17 2 plist bit(72); 11 18 11 19 /* end of include file lisp_atom_fmt.incl.pl1 */ 109 12 1 /* Include file lisp_cons_fmt.incl.pl1; 12 2* defines the format for a cons within the lisp system 12 3* D.Reed 4/1/71 */ 12 4 12 5 dcl consptr ptr, 12 6 1 cons aligned based (consptr), /* structure defining format for cons */ 12 7 2 car fixed bin(71), 12 8 2 cdr fixed bin(71), 12 9 12 10 1 cons_ptrs aligned based (consptr), /* for using car and cdr as pointers */ 12 11 2 car ptr, 12 12 2 cdr ptr, 12 13 12 14 12 15 1 cons_types aligned based (consptr), /* structure for extracting types out of cons */ 12 16 2 padding bit(21) unaligned, 12 17 2 car bit(9) unaligned, 12 18 2 padding2 bit(63) unaligned, 12 19 2 cdr bit(9) unaligned, 12 20 2 padend bit(42) unaligned; 12 21 12 22 dcl 1 cons_types36 aligned based, 12 23 2 car bit(36), 12 24 2 pada bit(36), 12 25 2 cdr bit(36), 12 26 2 padd bit(36); 12 27 12 28 12 29 /* end include file lisp_cons_fmt.incl.pl1 */ 110 13 1 /* BEGIN INCLUDE FILE lisp_control_chars.incl.pl1 */ 13 2 13 3 /* Last modified D. Reed 6/29/72 */ 13 4 13 5 dcl lisp_static_vars_$ctrlD ext fixed bin(71), 13 6 ctrlD fixed bin(71) defined (lisp_static_vars_$ctrlD); 13 7 13 8 dcl lisp_static_vars_$ctrlQ ext fixed bin(71), 13 9 ctrlQ fixed bin(71) defined (lisp_static_vars_$ctrlQ); 13 10 13 11 dcl lisp_static_vars_$ctrlR ext fixed bin(71), 13 12 ctrlR fixed bin(71) defined (lisp_static_vars_$ctrlR); 13 13 13 14 dcl lisp_static_vars_$ctrlW ext fixed bin(71), 13 15 ctrlW fixed bin(71) defined (lisp_static_vars_$ctrlW); 13 16 13 17 /* END INCLUDE FILE lisp_control_chars.incl.pl1 */ 13 18 111 14 1 /* MACLISP Compiled SUBR Block */ 14 2 14 3 dcl 1 subr_block_head based aligned, /* this is the first part of the subr block */ 14 4 2 next_compiled_block ptr, /* for xctblt */ 14 5 2 instructions(4) bit(36), /* the common entry code */ 14 6 2 subr_code_link_offset bin(17) unal, /* points to subr code link */ 14 7 2 rest_of_tsplp bit(18) unal, /* tsplp ,ic* */ 14 8 2 gcmark bit(18) unal, /* for garbage collector to remember seeing this block */ 14 9 2 gc_length fixed bin(17) unal, /* number garbage collectable objects */ 14 10 2 constants(1000) fixed bin(71); /* the compiled constants */ 14 11 14 12 /* alternate declaration of above */ 14 13 14 14 dcl 1 subr_block_head_overlay based aligned, 14 15 2 first_word bit(36), 14 16 2 second_word aligned, 14 17 3 padding bit(28) unaligned, 14 18 3 no_links_are_snapped bit(1) unaligned, /* "1"b if no itp links in this block have been snapped */ 14 19 3 more_padding bit(7) unaligned; 14 20 14 21 14 22 14 23 dcl 1 lisp_subr_links(1000) based aligned, /* the subr links follow the constants, and are the last gc'ed items */ 14 24 2 itp_base bit(3) unal, 14 25 2 itp_info bit(27) unal, /* produced by compiler */ 14 26 2 itp_mod bit(6) unal, 14 27 2 link_opr_tv_offset bit(18) unal, 14 28 2 mbz bit(12) unal, 14 29 2 further_mod bit(6) unal; /* when itp; this is indirect */ 14 30 14 31 14 32 dcl 1 subr_entries(1000) based aligned, /* these are next in block, not gc'able */ 14 33 2 nargs bit(18) unal, 14 34 2 code_offset bit(18) unal, /* offset of entrypoint in object segment */ 14 35 2 head_offset bin(17) unal, /* offset to common entry sequence in subr_block_head */ 14 36 2 rest_of_tsx0 bit(18) unal; /* tsx0 ,ic */ 14 37 14 38 14 39 dcl 1 link_to_subr_code based aligned, /* used by lisp_linker_ to find object segment */ 14 40 2 itp_to_linker ptr, /* points to linker, reset by linker to point to base of object seg */ 14 41 2 compilation_time fixed bin(71), /* used to verify linking to correct segment */ 14 42 2 name_length fixed bin(24), /* length of subroutines name...both segname and ename */ 14 43 2 name char(0 refer(link_to_subr_code.name_length)) unal; 14 44 14 45 dcl instructions_for_subr (4) bit(36) static init("000000000000000100110010111000001111"b, 14 46 "001111111111111100110101000001001111"b, 14 47 "001111111111111110010101010001001111"b, 14 48 "111111111111111110111010000000001000"b), 14 49 tsplp_ic_ind bit(18) static init("110111000000010100"b), 14 50 tsx0_ic bit(18) static init("111000000000000100"b); 14 51 14 52 dcl 1 array_links (1000) aligned based, /* come after entries, before link_to_subr_code */ 14 53 2 instruction bit(36) aligned, /* tspbp to array_link_snap operator 14 54* or eppbb *+2,* when snapped */ 14 55 2 control_word unaligned, /* controls what to snap to */ 14 56 3 type fixed bin(8), /* 0=S-expr, 2=fixnum, 3=flonum */ 14 57 3 ndims fixed bin(8), 14 58 3 atomic_symbol fixed bin(17), /* offset in constants to symbol which names array */ 14 59 2 pointer pointer; /* -> array_info block when snapped */ 14 60 14 61 dcl 1 array_link_count aligned based, /* comes after array_links, before link_to_subr_code */ 14 62 2 unused bit(36), 14 63 2 number_of_array_links fixed bin(17) unaligned, 14 64 2 must_be_zero bit(18) unaligned; /* 0 to distinguish from tsx0 in subr block with no array links */ 14 65 14 66 /* End of description of Compiled SUBR Block */ 112 15 1 /* lisp_maknum_table.incl.pl1 */ 15 2 15 3 dcl 1 maknum_table(0:divide(lisp_static_vars_$maknum_mask,8,24,0)) based(lisp_static_vars_$maknum_table_ptr) aligned, 15 4 2 first, 15 5 3 uid bit(27) unal, 15 6 3 type bit(9) unal, 15 7 2 second, 15 8 3 segno fixed bin(17) unal, 15 9 3 offset bit(18) unal, 15 10 15 11 1 maknum_table_ptrs(0:divide(lisp_static_vars_$maknum_mask,8,24,0)) based(lisp_static_vars_$maknum_table_ptr) aligned, 15 12 2 first, 15 13 3 uid bit(27) unal, 15 14 3 type bit(9) unal, 15 15 2 second ptr unal, 15 16 lisp_static_vars_$maknum_table_ptr ptr ext, 15 17 lisp_static_vars_$maknum_mask fixed bin(24) ext, /* 8*dim(maknum_table)-1 */ 15 18 lisp_static_vars_$maknum_left fixed bin(17) ext; 15 19 /* when calling rehash_maknum, contains number of entries in maknum_table */ 15 20 15 21 /* end maknum_table.incl.pl1 */ 113 114 115 116 117 go to join; /* obsolete "FSUBR" entry point */ 118 119 gcsubr: entry; 120 stack = stack_ptr; 121 stack_ptr = addr(stack->temp(2)); 122 stack -> temp(1) = nil; 123 join: if lisp_static_vars_$garbage_collect_inhibit then return; 124 125 /* go into (nointerrupt t) mode */ 126 127 lisp_static_vars_$i_am_gcing = "1"b; /* for CTRL/? */ 128 stack = stack_ptr; 129 stack_ptr = addr(stack -> temp(2)); 130 stack -> temp(1) = t_atom; 131 call lisp_fault_handler_$nointerrupt; 132 /* now the top of the stack has the previous status of the nointerrupt flag */ 133 134 135 /* Now safely clear the alloc fault word */ 136 137 call lisp_alloc_$get_fault_word(saved_alloc_fault_word); /* get fault word, make sure to zero it right. */ 138 139 if saved_alloc_fault_word & quit_fault /* do quit now */ 140 then do; 141 saved_alloc_fault_word = saved_alloc_fault_word & ^quit_fault; 142 call lisp_default_handler_$deferred_quit; /* but leave alarms for later */ 143 end; 144 145 146 start_time = virtual_cpu_time_(); 147 /* curtop = 0;*/ 148 call compute_total_allocation; 149 old_allocation = total_allocation; 150 /* total_allocation = 0;*/ 151 152 /* curseg = null();*/ 153 curgcmark = ^oldgcmark; 154 oldgcmark = curgcmark; 155 /* call new_segment_maker;*/ 156 157 if lisp_static_vars_$status_gctwa ^= nil 158 then do; 159 gcmode = Obarray_array; /* control switch for checking array types for obarrays */ 160 if addr(lisp_static_vars_$status_gctwa) -> lisp_ptr_type = fixnum_type 161 then if addr(lisp_static_vars_$status_gctwa) -> fixedb = 1 162 then addr(lisp_static_vars_$status_gctwa) -> fixedb = 0; /* only gctwa this time */ 163 else if addr(lisp_static_vars_$status_gctwa) -> fixedb = 0 164 then gcmode = -1; /* if switch is off, don't gctwa */ 165 else addr(lisp_static_vars_$status_gctwa) -> fixedb = 8; 166 end; 167 168 169 170 171 old_segs = lisp_gc_alm_$collect(gcmode=Obarray_array); /* call whizzy new gcer */ 172 173 /* copy_nil = nil; */ 174 /* call lisp_segment_manager_$get_lists (stack); /* use a new segment for gc stack */ 175 /* /* workptr = stack_ptr;*/ 176 /* bottom_ptr = ptr(unmkd_ptr,0)->stack_seg.marked_stack_bottom; 177*/* if baseno(bottom_ptr) ^= baseno(workptr) 178*/* then do; 179*/* call ioa_("Garbage collector: stack screwed up!!!! Entering debug."); 180*/* call debug; 181*/* dcl debug entry; 182*/* end; 183*/* 184*/* do while(workptr ^= bottom_ptr); 185*/* workptr = addrel(workptr,-2); 186*/* arg = workptr -> temp(1); 187*/* reti = 3; 188*/* go to collect; 189*/*ret(3): workptr -> temp(1) = arg; 190*/* end;*/ 191 192 193 /* idx = lisp_static_vars_$number_gc_ptrs; /* get number of ext ptrs */ 194 /* workptr = addr(lisp_static_vars_$garbage_collected_ptrs);*/ 195 /* do while (idx > 0); /* do until no more ptrs */ 196 /* idx = idx -1; 197*/* reti = 5;*/ 198 /* /* arg = workptr -> temp(1); /* use this as based ptr (lisp type) */ 199 /* go to collect; 200*/*ret(5): workptr -> temp(1) = arg; 201*/* workptr = addr(workptr->temp(2)); /* bump ptr address */ 202 /* end; 203*/* 204*/* 205*/* /* garbage collection of truly worthless atoms phase */ 206 /* 207*/* if gcmode < 0 then go to skip_gctwa; 208*/* 209*/* /* first pass over obarrays in obarray_list is for the purpose of garbage collecting */ 210 /* /* all of the worthy atoms which have not yet been seen. */ 211 /* /* for example, if the user had setq'ed a to b but no program or other list */ 212 /* /* structure referenced the atom b, we must make sure b is picked up by this pass */ 213 /* /* also, this handles difficulties with atoms whose values point into Obarray.buckets */ 214 /* 215*/* do chaser = obarray_list /* pass to collect worthy atoms and their plists and values */ 216 /* repeat(chaser -> obarray_list_element.next) 217*/* while(chaser ^= null()); 218*/* 219*/* obarray_ptr = chaser -> obarray_list_element.current -> array_info.array_data_ptr; 220*/* 221*/* do idx = 0 222*/* repeat(idx+1) 223*/* while(idx <= 127); 224*/* arg = obarray_ptr -> Obarray.char_atom(idx); /* these char_atoms are for single char atoms */ 225 /* reti = 7; 226*/* go to collect; 227*/*ret(7): obarray_ptr -> Obarray.char_atom(idx) = arg; /* put result back */ 228 /* end; 229*/* 230*/* do idx = 0 231*/* repeat(idx+1) 232*/* while(idx <= 510); /* these are the hash buckets */ 233 /* 234*/* do tempp = obarray_ptr -> Obarray.bucket(idx) 235*/* repeat (tempp -> cons_ptrs.cdr) 236*/* while (tempp -> cons.car ^= gc_mark); /* don't go past point in list we have seen */ 237 /* 238*/* arg = tempp -> cons.car; /* atom is at car of list */ 239 /* reti = 8; 240*/* /* now check to see if atom was not seen , yet is worthy */ 241 /* if addr(arg) -> based_ptr -> atom.value ^= gc_mark 242*/* then if addr(arg) -> based_ptr -> atom.value ^= 0 then go to collect; 243*/* else if addr(arg) -> based_ptr -> atom.plist ^= copy_nil then go to collect; 244*/* 245*/* go to no_check_car; 246*/*ret(8): if tempp -> cons.car = gc_mark /* in following atom's value or plist, 247*/* came to this part of bucket list */ 248 /* then go to premature_end_of_bucket; 249*/*no_check_car: end; 250*/*premature_end_of_bucket: 251*/* end; 252*/* end; 253*/* 254*/* /* second phase of gctwa operation -- must go through and make Obarray.bucket lists 255*/* from old bucket lists, preserving the worthy atoms, all of which have now 256*/* been collected */ 257 /* 258*/* do chaser = obarray_list 259*/* repeat (chaser -> obarray_list_element.next) 260*/* while (chaser ^= null()); 261*/* obarray_ptr = chaser -> obarray_list_element.current -> array_info.array_data_ptr; 262*/* 263*/* do idx = 0 264*/* repeat (idx + 1) 265*/* while (idx <= 510); 266*/* last = addr(obarray_ptr -> Obarray.bucket(idx)); /* last always point at place to splice next cons */ 267 /* 268*/* do tempp = obarray_ptr -> Obarray.bucket(idx) 269*/* repeat (tempp -> cons_ptrs.cdr) 270*/* while (tempp -> cons.car ^= gc_mark); /* stop at end of unseen bucket elements */ 271 /* 272*/* atptr = tempp -> cons_ptrs.car; /* get pointer to atom for worthiness check */ 273 /* if atptr -> cons.car = gc_mark /* then it is worthy */ 274 /* then do; 275*/* if curtop > 261116 then call new_segment_maker; 276*/* allocptr = addrel(curseg, curtop); /* allocate a cons */ 277 /* curtop = curtop + 4; 278*/* allocptr -> cons.car = atptr -> cons.cdr; /* the atom we are adding to bucket */ 279 /* last -> based_ptr = allocptr; /* append to bucket list so far */ 280 /* last = addr(allocptr -> cons.cdr); /* and remember where to append next */ 281 /* end; 282*/* end; 283*/* 284*/* last -> cons.car = tempp -> cons.cdr; /* terminate the list with the new location of the end */ 285 /* end; 286*/* end; 287*/* 288*/* 289*/*skip_gctwa: 290*/* /* now must scan over ungclist, and find all of those things which were not protected 291*/* by the other list structure we have seen */ 292 /* 293*/* do chaser = ungclist_ptr 294*/* repeat (chaser -> ungclist_element.next) 295*/* while (chaser ^= null()); 296*/* 297*/* allocptr = chaser -> ungclist_element.current; /* get pointer to ungc'ed array */ 298 /* call compute_array_size; 299*/* allocptr = allocptr -> array_info.array_data_ptr; 300*/* do left = size-2 by -2 to 0; 301*/* allocptr = addrel(allocptr,2); 302*/* if allocptr -> ungc_element = 0 then; 303*/* else if allocptr -> lisp_ptr_type & Numeric36 then; 304*/* else if allocptr -> lisp_ptr_type & String36 then go to make_fake; 305*/* else if allocptr -> lisp_ptr_type & Subr36 then; 306*/* else if allocptr -> based_ptr -> cons.car = gc_mark /* if already seen atom, cons or 307*/* bignum, then get new address */ 308 /* then allocptr -> ungc_element = allocptr -> based_ptr -> cons.cdr; 309*/* else do; 310*/*make_fake: if curtop > 261116 then call new_segment_maker; 311*/* atptr = addrel(curseg, curtop); 312*/* curtop = curtop + 4; 313*/* /* replace current array element by cons of itself with itself */ 314 /* atptr -> cons_ptrs.car = atptr; 315*/* atptr -> cons_ptrs.cdr = atptr; 316*/* allocptr -> based_ptr = atptr; 317*/* end; 318*/* 319*/* end; 320*/* end; 321*/* 322*/* 323*/* 324*/* /* now inform allocation routines of new segments */ 325 /* 326*/* curtop = divide(curtop + 3, 4, 17,0)*4; /* make curtop 0 (mod 4) */ 327 /* if curtop = 261120 then call new_segment_maker; /* if at very end of seg, skip to new one */ 328 /* 329*/* total_allocation = total_allocation + curtop; /* get current wordage */ 330 /* 331*/* old_segs = lisp_alloc_$cur_seg; /* remember old seg for later flushing */ 332 /* 333*/* lisp_alloc_$cur_seg = curseg; /* now set up all the necessary data */ 334 /* lisp_alloc_$consptr = addr(curseg->alloc_segment.tally_word); 335*/* consptr_ovly.mod = "101011"b; /* ad modifier */ 336 /* curseg -> alloc_segment.tally_word.seg_offset = bit(binary(curtop,18,0),18); 337*/* curseg -> alloc_segment.tally_word.tally = bit(binary(divide(mod(-1020-curtop,16384),4,18,0),12,0),12); 338*/* curseg -> alloc_segment.tally_word.delta = 4; 339*/* lisp_alloc_$seg_blk_cntr = divide(curtop+1024,16384,35,0) - 16;*/ 340 341 call compute_total_allocation; 342 call set_gc_blk_cntr; 343 344 345 346 /* now rehash the maknum table, after throwing away all old stuff not protected otherwise */ 347 /* note - allocation performed below will not be accounted for in msgs, gcsize, etc. */ 348 349 /* size = 0; /* see if there is any point to it */ 350 /* 351*/* if lisp_static_vars_$maknum_mask = -1 then goto norehash; 352*/* 353*/* 354*/* do idx = lbound(maknum_table,1) to hbound(maknum_table,1); 355*/* 356*/* if string(maknum_table(idx).first) 357*/* then do; 358*/* 359*/* if maknum_table(idx).first.type &(Subr|Numeric) 360*/* then size = size + 1; 361*/* else do; 362*/* workptr = ptr(baseptr(maknum_table(idx).second.segno),maknum_table(idx).second.offset); 363*/* if maknum_table(idx).first.type & String 364*/* then if workptr -> string_length < 0 365*/* then maknum_table_ptrs(idx).second = workptr -> copied_string.new_address; 366*/* else string(maknum_table(idx).first) = ""b; 367*/* else if workptr -> cons.car = gc_mark 368*/* then maknum_table_ptrs(idx).second = workptr -> cons_ptrs.cdr; 369*/* else string(maknum_table(idx).first) = ""b; 370*/* if string(maknum_table(idx).first) 371*/* then size = size + 1; 372*/* end; 373*/* end; 374*/* end; 375*/* 376*/* 377*/* 378*/* /* now rehash the table */ 379 /* 380*/* lisp_static_vars_$maknum_left = size; 381*/* 382*/* lisp_static_vars_$garbage_collect_inhibit = "1"b; 383*/* call lisp_alloc_$rehash_maknum; 384*/* lisp_static_vars_$garbage_collect_inhibit = "0"b; 385*/*norehash:*/ 386 387 /* final post-flushage */ 388 389 workptr = ptr(unmkd_ptr,0); /* get ptr to base of stack */ 390 workptr -> stack_seg.nil = nil; /* copy back two quantities */ 391 workptr -> stack_seg.true = t_atom; 392 393 workptr = ptr(stack_ptr, 0); /* segment of marked stack */ 394 reti = binary(rel(stack_ptr),17,0); /* and current height */ 395 call hcs_$truncate_seg(workptr, reti, (0)); /* make sure area above stack height is zero, as 396* it might be pointing into garbage collected space 397* which has just been moved! */ 398 /* call lisp_segment_manager_$free_lists (stack);*/ 399 400 do while(old_segs ^= null()); /* want to free all old segments */ 401 workptr = old_segs; 402 old_segs = workptr -> alloc_segment.next_seg; 403 call lisp_segment_manager_$free_lists(workptr); 404 end; 405 406 /* Have to do a post-pass over all file objects because those which 407* have not been seen are supposed to be automatically closed, 408* since there is no longer any way to reference them. In addition, 409* we have to clear the gc_mark bits */ 410 411 do allocptr = lisp_static_vars_$iochan_list 412 repeat (allocptr -> iochan.thread) 413 while (allocptr ^= null); 414 415 if allocptr -> iochan.gc_mark then allocptr -> iochan.gc_mark = "0"b; 416 else call lisp_io_control_$gc_flush(allocptr); 417 end; 418 419 gc_time = virtual_cpu_time_()-start_time; 420 lisp_static_vars_$gc_time = lisp_static_vars_$gc_time + gc_time; 421 meter_time = float(gc_time,63)/1e3; 422 if addr(ctrlD)->based_ptr->atom.value ^= nil /* want gc print */ 423 then call ioa_("^/;gc done: ^.3f msec., ^d words compacted to ^d words.^/", 424 meter_time, old_allocation, total_allocation); 425 426 427 428 /* restore status of nointerrupt flag */ 429 430 call lisp_fault_handler_$nointerrupt; 431 lisp_static_vars_$i_am_gcing = "0"b; 432 stack_ptr = addrel(stack_ptr, -2); 433 434 /* cleanup feature gets done here if released through a gc */ 435 436 if lisp_static_vars_$activate_gc_unwinder_kludge then do; 437 stack = stack_ptr; 438 stack_ptr = addr(stack -> temp(3)); 439 lisp_static_vars_$activate_gc_unwinder_kludge = "0"b; 440 do stack -> temp(1) = lisp_static_vars_$cleanup_list 441 repeat stack -> temp_ptr(1) -> cons.cdr 442 while (stack -> temp_type(1) = Cons); 443 stack -> temp(2) = stack -> temp_ptr(1) -> cons.car; 444 call lisp_$eval; 445 end; 446 lisp_static_vars_$cleanup_list_exists = "0"b; /* do once-only */ 447 go to lisp_static_vars_$gc_unwinder_kludge; /* resume unwindage */ 448 end; 449 450 fault_bits = saved_alloc_fault_word & fault_mask; /* check for interrupts while in allocator */ 451 if fault_bits ^= ""b then call lisp_default_handler_$alloc_fault(fault_bits); 452 saved_alloc_fault_word = saved_alloc_fault_word & ^fault_mask; 453 454 if addr (user_intr_array(20)) -> based_ptr -> atom.value ^= nil 455 then do; /* call gc-daemon function */ 456 stack = stack_ptr; 457 stack_ptr = addr(stack -> temp(5)); 458 stack -> temp(1) = addr(user_intr_array(20)) -> based_ptr -> atom.value; 459 stack -> temp(2) = lisp_static_vars_$space_names_atom -> atom_ptrs.value -> cons.car; /* list space */ 460 addr(stack -> temp(3)) -> fixnum_fmt.type_info, 461 addr(stack -> temp(4)) -> fixnum_fmt.type_info = fixnum_type; 462 addr(stack -> temp(3)) -> fixedb = lisp_static_vars_$gcmax - old_allocation; 463 addr(stack -> temp(4)) -> fixedb = lisp_static_vars_$gcmax - total_allocation; 464 call lisp_special_fns_$cons; 465 call lisp_special_fns_$cons; 466 call lisp_special_fns_$ncons; /* listify in case more than one space */ 467 call lisp_special_fns_$ncons; /* make another level of list for apply call */ 468 call lisp_$apply; 469 stack_ptr = stack; 470 end; 471 472 lisp_alloc_$alloc_fault_word = saved_alloc_fault_word; /* restore fault word */ 473 return; 474 475 476 /* Pseudo-subroutine to collect a value, and return its new location */ 477 478 /*collect: if arg = 0 then go to ret(reti); /* go to return if zero (uninit stack or atom value) */ 479 /* if addr(arg) -> lisp_ptr.itsmod ^= "100011"b then go to ret(reti); /* not lisp value -- unsnapped link, 480*/* perhaps, if o41 */ 481 /* if addr(arg)->lisp_ptr_type & NotConsOrAtsym36 = "0"b then go to collect_atsym_or_cons; 482*/* /* if addr(arg) -> lisp_ptr_type & Numeric36 then go to ret(reti); /* redundant, due to previous check since mod = 47 */ 483 /* if arg_points_at_odd_addr /* odd address, must fix this */ 484 /* then do; 485*/* arg_points_at_odd_addr = "0"b; /* force even address */ 486 /* stack -> gcinfo.reti = reti; 487*/* reti = 6; /* return to place where odd address fixed */ 488 /* stack = addrel(stack,4); 489*/* end; 490*/* 491*/* if addr(arg)->lisp_ptr_type & File36 then go to collect_file; 492*/* if addr(arg)->lisp_ptr_type & Array36 then go to collect_array; 493*/* if addr(arg)->lisp_ptr_type & Subr36 then go to collect_subr; 494*/* if addr(arg)->lisp_ptr_type & String36 then go to collect_string; 495*/* 496*/* /* check for big fixed point number */ 497 /* 498*/* if addr(arg) -> lisp_ptr_type & Bigfix36 then go to collect_bigfix; 499*/* 500*/*collect_atsym_or_cons: 501*/* if addr(arg)->based_ptr->cons.car = gc_mark /* already got this atom or cons */ 502 /* then do; 503*/* arg = addr(arg)->based_ptr->cons.cdr; /* get its new location */ 504 /* go to ret(reti); /* and return */ 505 /* end; 506*/* 507*/* 508*/* /* now it is known that some space is to be allocated, and the car and cdr are to be collected */ 509 /* 510*/* if addr(arg)->lisp_ptr_type & Atsym36 then do; 511*/* size = divide(addr(arg)->based_ptr->atom.pnamel+27,8,17,0)*2; 512*/* if size > Maximum_Reasonable_Size then do; /* that nasty bug is back */ 513 /* size = 4; /* turn damn thing into a cons */ 514 /* addr(arg) -> lisp_ptr.type = Cons; /* .. */ 515 /* if curtop + size > 261120 /* this lack of modularity */ 516 /* then call new_segment_maker; /* is for speed in the main path */ 517 /* allocptr = addrel(curseg, curtop); 518*/* call com_err_(0, "lisp_garbage_collector_", 519*/* "Bad atom ^w ^w ^w ^w ^w ^w at ^p -> ^p^/^-Possible bug in lisp.", 520*/* argo.w1, argo.w2, argo.w3, argo.w4, argo.w5, argo.w6, 521*/* addr(arg)->based_ptr, allocptr); 522*/* go to bad_atom_scrunched; 523*/* end; 524*/* end; 525*/* else size = 4; 526*/* 527*/* if curtop + size > 261120 then call new_segment_maker; /* we need more room */ 528 /* allocptr = addrel(curseg,curtop); /* allocate space */ 529 /*bad_atom_scrunched: 530*/* curtop = curtop+size; /* and indeed it is allocated */ 531 /* allocptr -> copy_words = addr(arg)->based_ptr->copy_words; /* copy whole structure */ 532 /* 533*/* addr(arg)->based_ptr->cons_ptrs.cdr = allocptr; /* save where it was moved to */ 534 /* addr(arg)->based_ptr->cons_types.cdr = addr(arg)->lisp_ptr.type; /* and save type */ 535 /* addr(arg)->based_ptr->cons.car = gc_mark; /* remember we hit this object */ 536 /* 537*/* /* now build a stack block for this collection */ 538 /* 539*/* stack -> gcinfo.loc = allocptr; 540*/* stack -> gcinfo.reti = reti; 541*/* stack -> gcinfo.type = addr(arg)->lisp_ptr.type; 542*/* 543*/* 544*/* stack = addrel(stack,4); /* bump stack ptr */ 545 /* arg = allocptr -> cons.car; /* get argument */ 546 /* reti = 0; /* cons first return */ 547 /* go to collect; /* call collector recursively */ 548 /*ret(0): allocptr = addrel(stack,-4)->gcinfo.loc; /* get cons addr into automatic ptr */ 549 /* allocptr->cons.car = arg; /* set car to ne value */ 550 /* arg = allocptr->cons.cdr; /* get new argument */ 551 /* reti = 1; /* and call collector again */ 552 /* go to collect; 553*/*ret(1): stack = addrel(stack,-4); /* pop stack */ 554 /* allocptr = stack -> gcinfo.loc; 555*/* allocptr -> cons.cdr = arg; 556*/* addr(arg)->based_ptr = allocptr; /* generate return of correct type */ 557 /* addr(arg)->lisp_ptr.type = stack -> gcinfo.type; 558*/* go to ret(stack->gcinfo.reti); /* and return to caller */ 559 /* 560*/* 561*/*collect_string: 562*/* size = addr(arg) -> based_ptr -> string_length; 563*/* if size < 0 564*/* then addr(arg)->based_ptr = addr(arg) -> based_ptr -> copied_string.new_address; 565*/* else do; 566*/* size = divide(size+11,8,17,0)*2; /* even number of words to allocate */ 567 /* if size > Maximum_Reasonable_Size then do; 568*/* size = 4; /* punt */ 569 /* if curtop + size > 261120 then call new_segment_maker; 570*/* allocptr = addrel(curseg,curtop); 571*/* call com_err_(0, "lisp_garbage_collector_", 572*/* "Bad string ^w ^w ^w ^w at ^p -> ^p^/^-Possible bug in lisp.", 573*/* argo.w1, argo.w2, argo.w3, argo.w4, addr(arg)->based_ptr, allocptr); 574*/* end; 575*/* else do; 576*/* if curtop + size > 261120 then call new_segment_maker; 577*/* allocptr = addrel(curseg,curtop); 578*/* end; 579*/* curtop = curtop + size; 580*/* allocptr -> copy_words = addr(arg)->based_ptr->copy_words; 581*/* addr(arg)->based_ptr -> string_length = -5050; /* mark string */ 582 /* addr(arg) -> based_ptr -> copied_string.new_address = allocptr; 583*/* addr(arg)->based_ptr=allocptr; 584*/* end; 585*/* addr(arg)->lisp_ptr_type = addr(arg)->lisp_ptr_type|String36; /* set type field */ 586 /* go to ret(reti); /* return */ 587 /* 588*/*collect_bigfix: 589*/* if addr(arg)->based_ptr->cons.car = gc_mark /* already got this bigfix */ 590 /* then do; 591*/* arg = addr(arg)->based_ptr->cons.cdr; /* get its new location */ 592 /* go to ret(reti); /* and return */ 593 /* end; 594*/* size = divide(addr(arg)->based_ptr->lisp_bignum.prec+2,2,18,0)*2; 595*/* if size > Maximum_Reasonable_Size then do; 596*/* size = 4; /* punt */ 597 /* if curtop+size > 261120 then call new_segment_maker; 598*/* allocptr = addrel(curseg,curtop); 599*/* call com_err_(0, "lisp_garbage_collector_", 600*/* "Bad bignum ^w ^w ^w ^w at ^p -> ^p^/^-Possible bug in lisp.", 601*/* argo.w1, argo.w2, argo.w3, argo.w4, addr(arg)->based_ptr, allocptr); 602*/* end; 603*/* else do; 604*/* if curtop+size > 261120 then call new_segment_maker; 605*/* allocptr = addrel(curseg,curtop); 606*/* end; 607*/* curtop = curtop+size; 608*/* allocptr->copy_words = addr(arg)->based_ptr->copy_words; 609*/* addr(arg)->based_ptr->cons.car = gc_mark; /* mark this as copied */ 610 /* addr(arg)->based_ptr->cons_ptrs.cdr = allocptr; 611*/* addr(addr(arg)->based_ptr->cons.cdr) -> lisp_ptr.type = Bigfix; 612*/* arg = addr(arg)->based_ptr->cons.cdr; 613*/* go to ret(reti); 614*/* 615*/* 616*/* 617*/*ret(6): /* fix up odd address item, such as snapped link */ 618 /* stack = addrel(stack, -4); 619*/* arg_points_at_odd_addr = "1"b; /* make odd address */ 620 /* go to ret(stack -> gcinfo.reti); /* return */ 621 /* 622*/*collect_subr: 623*/* if addr(arg) -> based_ptr -> subr_entries(1).rest_of_tsx0 = tsx0_ic then go to collect_compiled_subr; 624*/* go to ret(reti); /* type 3 subrs no longer supported */ 625 /* 626*/*collect_compiled_subr: 627*/* allocptr = addr(arg) -> based_ptr; 628*/* size = allocptr->subr_entries(1).head_offset-1; 629*/* allocptr = addrel(allocptr, size); 630*/* if allocptr -> subr_block_head.gcmark & curgcmark then go to ret(reti); 631*/* allocptr -> subr_block_head.gcmark = curgcmark; 632*/* left = allocptr->subr_block_head.gc_length; 633*/* size = size + 8; /* move down 8 words relative to arg */ 634 /* allocptr = addr(allocptr->subr_block_head.constants); 635*/* go to subr_join; 636*/* 637*/* /* 638*/* * files are kept in static storage, but they do contain 2 garbage-collectbale 639*/* * cells, the function and the namelist. 640*/* */ 641 /* 642*/*collect_file: 643*/* if addr(arg)->based_ptr -> iochan.gc_mark then go to ret(reti); /* already been collected */ 644 /* else addr(arg)->based_ptr -> iochan.gc_mark = "1"b; /* turn on already-been-seen bit */ 645 /* left = 2; /* now garbage-collect it as if it was an array */ 646 /* size = 14; 647*/* allocptr = addr(addr(arg)->based_ptr -> iochan.function); /* of just function and namelist */ 648 /* go to subr_join; 649*/* 650*/*collect_array: 651*/* 652*/* allocptr = addr(arg) -> based_ptr; /* -> array_info block */ 653 /* 654*/* if allocptr -> array_info.call_array_operator = old_array_stcd_instruction 655*/* then call convert_old_array; /* compatibility with old arrays */ 656 /* 657*/* if allocptr -> array_info.gc_mark&curgcmark then go to ret(reti); /* we have seen it this time */ 658 /* else allocptr -> array_info.gc_mark = curgcmark; /* otherwise mark it as such */ 659 /* if allocptr -> array_info.type = Dead_array then go to ret(reti); /* nothing more to do */ 660 /* if allocptr -> array_info.type = Un_gc_array then go to put_this_array_on_a_list; 661*/* if allocptr -> array_info.type = gcmode /* Obarray and in gctwa mode */ 662 /* then do; 663*/*put_this_array_on_a_list: 664*/* if curtop > 261116 then call new_segment_maker; 665*/* atptr = addrel(curseg,curtop); /* get space to add to list */ 666 /* curtop = curtop + 4; /* allocate the space */ 667 /* if allocptr -> array_info.type = Obarray_array 668*/* then do; 669*/* /* must append to _e_n_d of obarray list, 670*/* since we may be running in gctwa phase 671*/* already */ 672 /* if obarray_list_end = null() /* have no elements yet */ 673 /* then obarray_list, obarray_list_end = atptr; 674*/* else do; 675*/* obarray_list_end -> obarray_list_element.next = atptr; 676*/* obarray_list_end = atptr; 677*/* end; 678*/* obarray_list_end -> obarray_list_element.next = null(); 679*/* obarray_list_end -> obarray_list_element.current = addr(arg) -> based_ptr; 680*/* end; 681*/* else do; 682*/* atptr -> ungclist_element.next = ungclist_ptr; 683*/* atptr -> ungclist_element.current = addr(arg) -> based_ptr; 684*/* ungclist_ptr = atptr; 685*/* end; 686*/* 687*/* go to collect_number_array; /* don't mark contents, but do copy into 688*/* new lists seg */ 689 /* end; 690*/* 691*/* else if allocptr -> array_info.type = Readtable_array then do; /* readtables are strange */ 692 /* left = 9; /* number of markable double words */ 693 /* size = 145; /* total number of double words */ 694 /* go to collect_readtable_join; 695*/* end; 696*/* 697*/* else if allocptr -> array_info.type = Fixnum_array 698*/* then if allocptr -> array_info.minus_2_times_ndims ^= 0 then go to collect_number_array; 699*/* else go to ret(reti); /* external array - don't attempt to collect data area */ 700 /* else if allocptr -> array_info.type = Flonum_array then do; /* number array */ 701 /*collect_number_array: 702*/* call compute_array_size; 703*/* if allocptr -> array_info.type >= Fixnum_array 704*/* then if allocptr -> array_info.type <= Flonum_array 705*/* then size = divide(size+1, 2, 18, 0); /* convert to number of double words */ 706 /* left = 0; /* no markable words in this type of array */ 707 /* go to collect_readtable_join; 708*/* end; 709*/* /* come here to collect an ordinary S-expression array */ 710 /* 711*/* call compute_array_size; 712*/* left = size; /* all words are markable */ 713 /*collect_readtable_join: 714*/* 715*/* /* left = number of double words to mark. 716*/* size = number of double words total. */ 717 /* 718*/* /* the body of an array is in lists space so it has to be copied */ 719 /* 720*/* size = 2*(size + allocptr -> array_info.ndims); /* allow for dope vector */ 721 /* if curtop + size > 261120 then call new_segment_maker; 722*/* atptr = addrel(curseg, curtop); 723*/* curtop = curtop + size; 724*/* tempp = addrel(allocptr -> array_info.array_data_ptr, 725*/* allocptr -> array_info.minus_2_times_ndims); 726*/* atptr -> copy_words = tempp -> copy_words; /* copy over the body of the array */ 727 /* allocptr -> array_info.array_data_ptr = addrel(atptr, 2*allocptr -> array_info.ndims); 728*/* 729*/* allocptr = allocptr -> array_info.array_data_ptr; /* -> data to be marked */ 730 /* 731*/* /* now walk over the garbage-collectable portion of the array */ 732 /* 733*/*subr_join: 734*/* if left = 0 then go to ret(reti); /* no data at all */ 735 /* stack -> array_save.argument = arg; /* save argument */ 736 /* stack -> array_save.reti = reti; 737*/* do while(left > 0); 738*/* stack -> array_save.allocptr = allocptr; 739*/* stack -> array_save.left = left; 740*/* stack = addrel(stack,4); /* size of array save */ 741 /* reti = 2; 742*/* arg = allocptr -> cons.car; /* get thing to gc */ 743 /* go to collect; 744*/*ret(2): stack = addrel(stack,-4); 745*/* allocptr = stack -> array_save.allocptr; 746*/* allocptr -> cons.car = arg; 747*/* allocptr = addr(allocptr->cons.cdr); 748*/* left = stack -> array_save.left-1; 749*/* end; 750*/* 751*/* arg = stack -> array_save.argument; 752*/* go to ret(stack -> array_save.reti); 753*/* 754*/* /* declarations of structures used above */ 755 /* 756*/*dcl 1 gcinfo based aligned, 757*/* 2 loc ptr, 758*/* 2 reti fixed bin, 759*/* 2 type bit(9); 760*/* 761*/*dcl 1 subr_info based aligned, 762*/* 2 nargs fixed bin(17) unal, 763*/* 2 infop fixed bin(17) unal, 764*/* 2 instructions(3) bit(36), 765*/* 2 nwords fixed bin(17) unal, /* this is the address of a tsblp instruction */ 766 /* 2 tsblp_inst bit(18) unal, 767*/* 2 gcmark bit(18)aligned; 768*/* 769*/*dcl 1 array_save aligned based, 770*/* 2 argument fixed bin(71), 771*/* 2 reti fixed bin(17) unaligned, 772*/* 2 left fixed bin(17) unaligned, 773*/* 2 allocptr unaligned pointer; 774*/* 775*/* /* This routine converts an old array to a new array, for compatibility */ 776 /* /* allocptr -> old array, which is clobbered by array_info for new array (always shorter) */ 777 /* 778*/*convert_old_array: proc; 779*/* 780*/*dcl ndims fixed bin init(old_array.ndims), 781*/* (old_data_ptr, new_data_ptr) pointer, 782*/* size fixed bin(18), 783*/* bound_product fixed bin(18), 784*/* number_of_double_words fixed bin(18), 785*/* k fixed bin(18), 786*/* i fixed bin, 787*/* array_type fixed bin; 788*/* 789*/*dcl 1 old_array aligned based(allocptr), 790*/* 2 ndims fixed bin(17) unaligned, 791*/* 2 infop fixed bin(17) unaligned, 792*/* 2 stcd_inst bit(36), 793*/* 2 inst_pairs (ndims), 794*/* 3 ldq_or_adq bit(36), 795*/* 3 mpy_or_qls, 796*/* 4 bound bit(18) unaligned, 797*/* 4 rest_of_inst bit(18) unaligned, 798*/* 2 tmi_error bit(36), 799*/* 2 cmpq, 800*/* 3 total_bound bit(18) unaligned, 801*/* 3 rest_of_inst bit(18) unaligned, 802*/* 2 more (6) bit(36), 803*/* 2 gc_info, 804*/* 3 (nw, gcm, at, pb) fixed bin(17) unaligned, 805*/* 2 data (1000) fixed bin(71); 806*/* 807*/*dcl 1 dope_vector (ndims) aligned based(new_data_ptr), 808*/* 2 bounds fixed bin(35), 809*/* 2 multiplier fixed bin(35); 810*/* 811*/* /* instructions to be put into a new array. copied from lisp_array_fcns_ */ 812 /* 813*/*dcl array_instructions(0:5, 0:3) bit(36) static init( /* index by array_type, instx */ 814 /* "001000000001001010010111011001010000"b, 815*/* "101000000000000000010011111001000110"b, 816*/* "010000000000000000111001000001000000"b, 817*/* ""b, /* S-expr, Un-gc: ldaq lb|0,ql tra bp|0 */ 818 /* 819*/* "001000000001001010010111011001010000"b, 820*/* "101000000000000000010011111001000110"b, 821*/* "010000000000000000111001000001000000"b, 822*/* ""b, /* S-expr, Un-gc: ldaq lb|0,ql tra bp|0 */ 823 /* 824*/* "001000000001001010010111011001010000"b, 825*/* "000100000000100111010011101000000111"b, 826*/* "101000000000000000010011110001000110"b, 827*/* "010000000000000000111001000001000000"b, /* fixnum - lda 040047,dl ldq lb|0,ql tra bp|0 */ 828 /* 829*/* "001000000001001010010111011001010000"b, 830*/* "000010000000100111010011101000000111"b, 831*/* "101000000000000000010011110001000110"b, 832*/* "010000000000000000111001000001000000"b, /* flonum - lda 020047,dl ldq lb|0,ql tra bp|0 */ 833 /* 834*/* "001000000001001100010111011001010000"b, 835*/* "000100000000100111010011101000000111"b, 836*/* "101000000000000000010011110001000110"b, 837*/* "010000000000000000111001000001000000"b, /* readtable - lda 040047,dl ldq lb|0,ql tra bp|0 */ 838 /* 839*/* "001000000001001010010111011001010000"b, 840*/* "101000000000000000010011111001000110"b, 841*/* "010000000000000000111001000001000000"b, 842*/* ""b); /* obarray - ldaq lb|0,ql tra bp|0 */ 843 /* 844*/* 845*/* old_data_ptr = addr(old_array.data); 846*/* number_of_double_words = divide(fixed(old_array.total_bound, 18), 2, 18, 0); 847*/* size = 2*(ndims + number_of_double_words); /* number of words required for data area */ 848 /* if curtop + size > 261120 then call new_segment_maker; /* allocate new data area */ 849 /* new_data_ptr = addrel(curseg, curtop); 850*/* curtop = curtop + size; 851*/* 852*/* size = size - 2*ndims; /* subtract dope vector */ 853 /* addrel(new_data_ptr, 2*ndims) -> copy_words = /* move the data */ 854 /* old_data_ptr -> copy_words; 855*/* 856*/* /* now fill in the dope vector */ 857 /* 858*/* bound_product = 1; 859*/* do i = 1 by 1 while (i < ndims); 860*/* k = fixed(old_array.bound(i)); /* pick up old multiplier */ 861 /* dope_vector(i).multiplier, dope_vector(i+1).bounds = k; 862*/* bound_product = bound_product * k; 863*/* end; 864*/* dope_vector(ndims).multiplier = 2; 865*/* dope_vector(1).bounds = divide(number_of_double_words, bound_product, 18, 0); 866*/* 867*/* /* compute type of old array and convert to new type codes */ 868 /* 869*/* array_type = old_array.gc_info.at; 870*/* if array_type = 2 then array_type = Obarray_array; 871*/* else if array_type = 3 then array_type = Un_gc_array; 872*/* else if array_type = 1 then array_type = Readtable_array; 873*/* else array_type = S_expr_array; 874*/* 875*/* /* make an array info block, clobbering the old array */ 876 /* 877*/* allocptr -> array_info.ndims = ndims; 878*/* allocptr -> array_info.array_data_ptr = addrel(new_data_ptr, 2*ndims); 879*/* allocptr -> array_info.minus_2_times_ndims = -2*ndims; 880*/* allocptr -> array_info.gc_mark = ""b; 881*/* allocptr -> array_info.type = array_type; 882*/* allocptr -> array_info.call_array_operator = array_instructions(array_type, 0); 883*/* do i = 1 to 3; 884*/* allocptr -> array_info.array_load_sequence(i) = array_instructions(array_type, i); 885*/* end; 886*/* 887*/*end convert_old_array; 888*/* 889*/*new_segment_maker: proc; 890*/* 891*/* total_allocation = total_allocation + curtop; 892*/* call lisp_segment_manager_$get_lists (new_seg); 893*/* new_seg -> alloc_segment.next_seg = curseg; 894*/* curseg = new_seg; 895*/* curtop = 4; 896*/* 897*/*end new_segment_maker;*/ 898 899 900 901 /* subroutine to set gc_blk_cntr according to the gcsize and gcmin parameters. 902* total_allocation must be set to the total number of words in lists space */ 903 904 set_gc_blk_cntr: proc; 905 906 dcl num_words_to_gc_at fixed bin(35), 907 lisp_static_vars_$gcsize fixed bin(35) external, 908 lisp_static_vars_$gcmin external, 909 lisp_static_vars_$gcmin_fraction bit(1) external, 910 lisp_static_vars_$gcmin_fixed fixed bin(35) based(addr(lisp_static_vars_$gcmin)), 911 lisp_static_vars_$gcmin_float float bin(27) based(addr(lisp_static_vars_$gcmin)); 912 913 if lisp_static_vars_$gcmin_fraction 914 then num_words_to_gc_at = fixed(float(total_allocation) / 915 (1 - lisp_static_vars_$gcmin_float), 35); 916 else num_words_to_gc_at = total_allocation + lisp_static_vars_$gcmin_fixed; 917 918 if num_words_to_gc_at < lisp_static_vars_$gcsize 919 then num_words_to_gc_at = lisp_static_vars_$gcsize; 920 921 /* round up to next multiple of 16K */ 922 923 lisp_alloc_$gc_blk_cntr = - divide(24 + divide(num_words_to_gc_at - total_allocation + 1023, 1024, 35, 0), 16, 35, 0); 924 925 end set_gc_blk_cntr; 926 927 928 /** entry to be called after the gc parameters have been changed **/ 929 930 set_gc_params: entry; 931 932 /* compute the value of total_allocation, then call above subroutine */ 933 934 call compute_total_allocation; 935 call set_gc_blk_cntr; 936 return; 937 938 compute_total_allocation: proc; 939 940 total_allocation = 0; 941 do curseg = lisp_alloc_$cur_seg 942 repeat (curseg -> alloc_segment.next_seg) 943 while (curseg ^= null); 944 total_allocation = total_allocation + fixed(curseg -> alloc_segment.tally_word.seg_offset, 18); 945 end; 946 end compute_total_allocation; 947 948 949 /*compute_array_size: procedure; 950*/* 951*/* size = 1; /* compute size of array */ 952 /* do left = -(allocptr -> array_info.ndims) by 1 while(left < 0); 953*/* size = size * allocptr -> array_info.array_data_ptr -> array_data.dope_vector(left+1).bounds; 954*/* end; 955*/*end compute_array_size;*/ 956 957 end lisp_garbage_collector_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 04/18/00 1123.2 lisp_garbage_collector_.pl1 >udd>sm>ds>w>ml>lisp_garbage_collector_.pl1 99 1 03/27/82 0537.0 lisp_free_storage.incl.pl1 >ldd>incl>lisp_free_storage.incl.pl1 100 2 03/27/82 0537.1 lisp_array_fmt.incl.pl1 >ldd>incl>lisp_array_fmt.incl.pl1 101 3 03/27/82 0537.0 lisp_iochan.incl.pl1 >ldd>incl>lisp_iochan.incl.pl1 102 4 03/27/82 0537.0 lisp_nums.incl.pl1 >ldd>incl>lisp_nums.incl.pl1 103 5 03/27/82 0537.0 lisp_ptr_fmt.incl.pl1 >ldd>incl>lisp_ptr_fmt.incl.pl1 104 6 07/06/83 1211.5 lisp_stack_seg.incl.pl1 >ldd>incl>lisp_stack_seg.incl.pl1 105 7 03/27/82 0536.9 lisp_string_fmt.incl.pl1 >ldd>incl>lisp_string_fmt.incl.pl1 106 8 03/27/82 0537.0 lisp_bignum_fmt.incl.pl1 >ldd>incl>lisp_bignum_fmt.incl.pl1 107 9 03/27/82 0537.0 lisp_stack_fmt.incl.pl1 >ldd>incl>lisp_stack_fmt.incl.pl1 108 10 03/27/82 0537.0 lisp_common_vars.incl.pl1 >ldd>incl>lisp_common_vars.incl.pl1 109 11 03/27/82 0537.1 lisp_atom_fmt.incl.pl1 >ldd>incl>lisp_atom_fmt.incl.pl1 110 12 03/27/82 0537.0 lisp_cons_fmt.incl.pl1 >ldd>incl>lisp_cons_fmt.incl.pl1 111 13 03/27/82 0537.0 lisp_control_chars.incl.pl1 >ldd>incl>lisp_control_chars.incl.pl1 112 14 03/27/82 0537.0 lisp_comp_subr_block.incl.pl1 >ldd>incl>lisp_comp_subr_block.incl.pl1 113 15 03/27/82 0537.0 lisp_maknum_table.incl.pl1 >ldd>incl>lisp_maknum_table.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. Cons constant bit(9) initial packed unaligned dcl 5-17 ref 440 Obarray_array constant fixed bin(17,0) initial dcl 2-20 ref 159 171 addr builtin function dcl 8 ref 121 129 160 160 160 163 165 422 438 454 457 458 460 460 462 463 913 916 addrel builtin function dcl 8 ref 432 alloc_segment based structure level 1 dcl 1-3 allocptr 000116 automatic pointer dcl 8 set ref 411* 411* 415 415 416* 417 atom based structure level 1 dcl 11-5 atom_ptrs based structure level 1 dcl 11-5 based_ptr based pointer dcl 5-16 ref 422 454 458 binary builtin function dcl 8 ref 394 car based fixed bin(71,0) level 2 dcl 12-5 ref 443 459 cdr 2 based fixed bin(71,0) level 2 dcl 12-5 ref 445 cons based structure level 1 dcl 12-5 ctrlD defined fixed bin(71,0) dcl 13-5 set ref 422 curgcmark 000104 automatic bit(18) dcl 8 set ref 153* 154 curseg 000102 automatic pointer dcl 8 set ref 941* 941* 944* 945 divide builtin function dcl 8 ref 923 923 fault_bits 000127 automatic bit(36) dcl 8 set ref 450* 451 451* fault_mask constant bit(36) initial packed unaligned dcl 1-3 ref 450 452 fixed builtin function dcl 8 ref 913 944 fixedb 1 based fixed bin(17,0) level 2 dcl 4-4 set ref 160 160* 163 165* 462* 463* fixnum_fmt based structure level 1 dcl 4-4 fixnum_type constant bit(36) initial dcl 4-4 ref 160 460 flags 15 based structure level 2 packed packed unaligned dcl 3-13 float builtin function dcl 8 ref 421 913 gc_mark 15(03) based bit(1) level 3 packed packed unaligned dcl 3-13 set ref 415 415* gc_time 000134 automatic fixed bin(71,0) dcl 8 set ref 419* 420 421 gcmode 000114 automatic fixed bin(17,0) initial dcl 8 set ref 8* 159* 163* 171 hcs_$truncate_seg 000022 constant entry external dcl 8 ref 395 ioa_ 000026 constant entry external dcl 8 ref 422 iochan based structure level 1 dcl 3-13 lisp_$apply 000044 constant entry external dcl 8 ref 468 lisp_$eval 000046 constant entry external dcl 8 ref 444 lisp_alloc_$alloc_fault_word 000072 external static bit(36) dcl 1-3 set ref 472* lisp_alloc_$cur_seg 000076 external static pointer dcl 1-3 ref 941 lisp_alloc_$gc_blk_cntr 000074 external static fixed bin(17,0) dcl 1-3 set ref 923* lisp_alloc_$get_fault_word 000032 constant entry external dcl 8 ref 137 lisp_default_handler_$alloc_fault 000036 constant entry external dcl 8 ref 451 lisp_default_handler_$deferred_quit 000034 constant entry external dcl 8 ref 142 lisp_fault_handler_$nointerrupt 000020 constant entry external dcl 8 ref 131 430 lisp_gc_alm_$collect 000010 constant entry external dcl 8 ref 171 lisp_io_control_$gc_flush 000012 constant entry external dcl 8 ref 416 lisp_ptr_type based bit(36) dcl 5-17 ref 160 lisp_segment_manager_$free_lists 000024 constant entry external dcl 8 ref 403 lisp_special_fns_$cons 000040 constant entry external dcl 8 ref 464 465 lisp_special_fns_$ncons 000042 constant entry external dcl 8 ref 466 467 lisp_static_vars_$activate_gc_unwinder_kludge 000070 external static bit(1) dcl 90 set ref 436 439* lisp_static_vars_$cleanup_list 000062 external static fixed bin(71,0) dcl 90 ref 440 lisp_static_vars_$cleanup_list_exists 000064 external static bit(1) dcl 90 set ref 446* lisp_static_vars_$ctrlD 000114 external static fixed bin(71,0) dcl 13-5 ref 422 422 lisp_static_vars_$garbage_collect_inhibit 000050 external static bit(36) dcl 8 ref 123 lisp_static_vars_$gc_mark_bits 000014 external static bit(18) dcl 8 set ref 153 153 154* 154 lisp_static_vars_$gc_time 000060 external static fixed bin(71,0) dcl 8 set ref 420* 420 lisp_static_vars_$gc_unwinder_kludge 000066 external static label variable dcl 90 ref 447 lisp_static_vars_$gcmax 000054 external static fixed bin(35,0) dcl 8 ref 462 463 lisp_static_vars_$gcmin 000120 external static fixed bin(17,0) dcl 906 set ref 913 916 lisp_static_vars_$gcmin_fixed based fixed bin(35,0) dcl 906 ref 916 lisp_static_vars_$gcmin_float based float bin(27) dcl 906 ref 913 lisp_static_vars_$gcmin_fraction 000122 external static bit(1) packed unaligned dcl 906 ref 913 lisp_static_vars_$gcsize 000116 external static fixed bin(35,0) dcl 906 ref 918 918 lisp_static_vars_$i_am_gcing 000052 external static bit(1) dcl 8 set ref 127* 431* lisp_static_vars_$iochan_list 000110 external static pointer dcl 10-6 ref 411 lisp_static_vars_$nil 000106 external static fixed bin(71,0) dcl 10-6 ref 122 122 157 157 390 390 422 422 454 454 lisp_static_vars_$space_names_atom 000056 external static pointer dcl 8 ref 459 lisp_static_vars_$stack_ptr 000100 external static pointer dcl 10-6 set ref 120 120 121* 121 128 128 129* 129 393 393 394 394 432* 432 432 432 437 437 438* 438 456 456 457* 457 469* 469 lisp_static_vars_$status_gctwa 000016 external static fixed bin(71,0) dcl 8 set ref 157 160 160 160 163 165 lisp_static_vars_$t_atom 000102 external static fixed bin(71,0) dcl 10-6 ref 130 130 391 391 lisp_static_vars_$unmkd_ptr 000104 external static pointer dcl 10-6 ref 389 389 lisp_static_vars_$user_intr_array 000112 external static fixed bin(71,0) array dcl 10-45 ref 454 454 458 458 meter_time 000132 automatic float bin(63) dcl 8 set ref 421* 422* next_seg based pointer level 2 dcl 1-3 ref 402 945 nil 12 based fixed bin(71,0) level 2 in structure "stack_seg" dcl 6-5 in procedure "lisp_garbage_collector_" set ref 390* nil defined fixed bin(71,0) dcl 10-6 in procedure "lisp_garbage_collector_" ref 122 157 390 422 454 null builtin function dcl 8 ref 8 8 8 400 411 941 num_words_to_gc_at 000146 automatic fixed bin(35,0) dcl 906 set ref 913* 916* 918 918* 923 obarray_list 000110 automatic pointer initial dcl 8 set ref 8* obarray_list_element based structure level 1 dcl 8 obarray_list_end 000112 automatic pointer initial dcl 8 set ref 8* old_allocation 000101 automatic fixed bin(34,0) dcl 8 set ref 149* 422* 462 old_segs 000130 automatic pointer dcl 8 set ref 171* 400 401 402* oldgcmark defined bit(18) dcl 8 set ref 153 154* ptr builtin function dcl 8 ref 389 393 push_down_list_ptr_types based structure array level 1 dcl 9-7 quit_fault constant bit(36) initial packed unaligned dcl 1-3 ref 139 141 rel builtin function dcl 8 ref 394 reti 000115 automatic fixed bin(17,0) dcl 8 set ref 394* 395* saved_alloc_fault_word 000126 automatic bit(36) packed unaligned dcl 8 set ref 137* 139 141* 141 450 452* 452 472 seg_offset 2 based bit(18) level 3 packed packed unaligned dcl 1-3 ref 944 stack 000122 automatic pointer dcl 8 set ref 120* 121 122 128* 129 130 437* 438 440 440 443 443 445 456* 457 458 459 460 460 462 463 469 stack_ptr defined pointer dcl 10-6 set ref 120 121* 128 129* 393 394 432* 432 437 438* 456 457* 469* stack_seg based structure level 1 dcl 6-5 start_time 000124 automatic fixed bin(52,0) dcl 8 set ref 146* 419 t_atom defined fixed bin(71,0) dcl 10-6 ref 130 391 tally_word 2 based structure level 2 dcl 1-3 temp based fixed bin(71,0) array dcl 9-7 set ref 121 122* 129 130* 438 440* 443* 457 458* 459* 460 460 462 463 temp_ptr based pointer array dcl 9-7 ref 443 445 temp_type 0(21) based bit(9) array level 2 packed packed unaligned dcl 9-7 ref 440 thread 4 based pointer level 2 dcl 3-13 ref 417 total_allocation 000100 automatic fixed bin(34,0) dcl 8 set ref 149 422* 463 913 916 923 940* 944* 944 true 14 based fixed bin(71,0) level 2 dcl 6-5 set ref 391* type_info based bit(36) level 2 dcl 4-4 set ref 460* 460* ungclist_ptr 000106 automatic pointer initial dcl 8 set ref 8* unmkd_ptr defined pointer dcl 10-6 ref 389 user_intr_array defined fixed bin(71,0) array dcl 10-45 set ref 454 458 value based fixed bin(71,0) level 2 in structure "atom" dcl 11-5 in procedure "lisp_garbage_collector_" ref 422 454 458 value based pointer level 2 in structure "atom_ptrs" dcl 11-5 in procedure "lisp_garbage_collector_" ref 459 virtual_cpu_time_ 000030 constant entry external dcl 8 ref 146 419 workptr 000120 automatic pointer dcl 8 set ref 389* 390 391 393* 395* 401* 402 403* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Array internal static bit(9) initial packed unaligned dcl 5-17 Array36 internal static bit(36) initial dcl 5-17 Atomic internal static bit(9) initial packed unaligned dcl 5-17 Atomic36 internal static bit(36) initial dcl 5-17 Atsym internal static bit(9) initial packed unaligned dcl 5-17 Atsym36 internal static bit(36) initial dcl 5-17 Bigfix internal static bit(9) initial packed unaligned dcl 5-17 Bigfix36 internal static bit(36) initial dcl 5-17 Bignum internal static bit(9) initial packed unaligned dcl 5-17 Bignum36 internal static bit(36) initial dcl 5-17 Cons36 internal static bit(36) initial dcl 5-17 Dead_array internal static fixed bin(17,0) initial dcl 2-20 File internal static bit(9) initial packed unaligned dcl 5-17 File36 internal static bit(36) initial dcl 5-17 Fixed internal static bit(9) initial packed unaligned dcl 5-17 Fixed36 internal static bit(36) initial dcl 5-17 Fixnum_array internal static fixed bin(17,0) initial dcl 2-20 Float internal static bit(9) initial packed unaligned dcl 5-17 Float36 internal static bit(36) initial dcl 5-17 Flonum_array internal static fixed bin(17,0) initial dcl 2-20 Maximum_Reasonable_Size internal static fixed bin(18,0) initial dcl 8 NotConsOrAtsym36 internal static bit(36) initial dcl 5-17 Numeric internal static bit(9) initial packed unaligned dcl 5-17 Numeric36 internal static bit(36) initial dcl 5-17 Obarray based structure level 1 dcl 8 Readtable_array internal static fixed bin(17,0) initial dcl 2-20 S_expr_array internal static fixed bin(17,0) initial dcl 2-20 String internal static bit(9) initial packed unaligned dcl 5-17 String36 internal static bit(36) initial dcl 5-17 Subr internal static bit(9) initial packed unaligned dcl 5-17 Subr36 internal static bit(36) initial dcl 5-17 SubrNumeric36 internal static bit(36) initial dcl 5-17 System_Subr internal static bit(9) initial packed unaligned dcl 5-17 System_Subr36 internal static bit(36) initial dcl 5-17 Un_gc_array internal static fixed bin(17,0) initial dcl 2-20 Uncollectable internal static bit(9) initial packed unaligned dcl 5-17 Undefined internal static bit(72) initial packed unaligned dcl 5-17 ZERO internal static fixed bin(17,0) initial dcl 2-37 alloc_fault_word defined bit(36) packed unaligned dcl 1-3 alrm_fault internal static bit(36) initial packed unaligned dcl 1-3 arg automatic fixed bin(71,0) dcl 8 arg_ovly based structure level 1 dcl 8 argo based structure level 1 dcl 95 array_atom defined fixed bin(71,0) dcl 10-6 array_data based structure level 1 dcl 2-31 array_info based structure level 1 dcl 2-8 array_link_count based structure level 1 dcl 14-61 array_links based structure array level 1 dcl 14-52 atom_double_words based structure level 1 dcl 11-5 atptr automatic pointer dcl 8 baseno builtin function dcl 8 binding_block based structure level 1 dcl 9-7 binding_top defined pointer dcl 10-6 bindings based structure array level 1 dcl 9-7 bit builtin function dcl 8 bottom_ptr automatic pointer dcl 8 call_array_operator internal static bit(36) initial packed unaligned dcl 6-68 call_dead_array_operator internal static bit(36) initial packed unaligned dcl 6-68 catch_frame defined pointer dcl 10-6 chaser automatic pointer dcl 8 com_err_ 000000 constant entry external dcl 8 cons_ptrs based structure level 1 dcl 12-5 cons_types based structure level 1 dcl 12-5 cons_types36 based structure level 1 dcl 12-22 consptr automatic pointer dcl 12-5 consptr_ovly based structure level 1 dcl 1-3 copied_string based structure level 1 dcl 8 copy_nil automatic fixed bin(71,0) dcl 8 copy_words based fixed bin(35,0) array dcl 8 cput_fault internal static bit(36) initial packed unaligned dcl 1-3 ctrlQ defined fixed bin(71,0) dcl 13-8 ctrlR defined fixed bin(71,0) dcl 13-11 ctrlW defined fixed bin(71,0) dcl 13-14 curtop automatic fixed bin(18,0) dcl 8 err_frame defined pointer dcl 10-6 err_recp defined pointer dcl 10-6 eval_frame defined pointer dcl 10-6 flag_reset_mask internal static bit(36) initial dcl 3-13 flonum_fmt based structure level 1 dcl 4-4 flonum_type internal static bit(36) initial dcl 4-4 gc_mark internal static fixed bin(71,0) initial dcl 8 hbound builtin function dcl 8 idx automatic fixed bin(17,0) dcl 8 instructions_for_subr internal static bit(36) initial array packed unaligned dcl 14-45 ioa_$ioa_stream_nnl 000000 constant entry external dcl 8 last automatic pointer dcl 8 lbound builtin function dcl 8 left automatic fixed bin(17,0) dcl 8 link_to_subr_code based structure level 1 dcl 14-39 lisp_alloc_$alloc_info external static bit(288) dcl 1-3 lisp_alloc_$consptr external static pointer dcl 1-3 lisp_alloc_$rehash_maknum 000000 constant entry external dcl 8 lisp_alloc_$seg_blk_cntr external static fixed bin(17,0) dcl 1-3 lisp_bignum based structure level 1 dcl 8-3 lisp_print_$type_string 000000 constant entry external dcl 8 lisp_ptr based structure level 1 dcl 5-17 lisp_segment_manager_$get_lists 000000 constant entry external dcl 8 lisp_special_fns_$list 000000 constant entry external dcl 8 lisp_static_vars_$array_atom external static fixed bin(71,0) dcl 10-6 lisp_static_vars_$binding_top external static pointer dcl 10-6 lisp_static_vars_$catch_frame external static pointer dcl 10-6 lisp_static_vars_$ctrlQ external static fixed bin(71,0) dcl 13-8 lisp_static_vars_$ctrlR external static fixed bin(71,0) dcl 13-11 lisp_static_vars_$ctrlW external static fixed bin(71,0) dcl 13-14 lisp_static_vars_$err_frame external static pointer dcl 10-6 lisp_static_vars_$err_recp external static pointer dcl 10-6 lisp_static_vars_$eval_frame external static pointer dcl 10-6 lisp_static_vars_$garbage_collected_ptrs external static fixed bin(71,0) dcl 8 lisp_static_vars_$lisp_static_vars_ external static structure level 1 unaligned dcl 10-6 lisp_static_vars_$maknum_left external static fixed bin(17,0) dcl 15-3 lisp_static_vars_$maknum_mask external static fixed bin(24,0) dcl 15-3 lisp_static_vars_$maknum_table_ptr external static pointer dcl 15-3 lisp_static_vars_$number_gc_ptrs external static fixed bin(17,0) dcl 8 lisp_static_vars_$obarray external static fixed bin(71,0) dcl 10-6 lisp_static_vars_$prog_frame external static pointer dcl 10-6 lisp_static_vars_$star_rset external static fixed bin(71,0) dcl 10-45 lisp_static_vars_$top_level external static label variable dcl 10-6 lisp_static_vars_$tty_input_chan external static pointer dcl 10-6 lisp_static_vars_$tty_output_chan external static pointer dcl 10-6 lisp_static_vars_$unwp_frame external static pointer dcl 10-6 lisp_string based structure level 1 dcl 7-6 lisp_subr_links based structure array level 1 dcl 14-23 maknum_table based structure array level 1 dcl 15-3 maknum_table_ptrs based structure array level 1 dcl 15-3 mod builtin function dcl 8 new_seg automatic pointer dcl 8 nil_ptr based pointer dcl 10-6 obarray defined fixed bin(71,0) dcl 10-6 obarray_ptr automatic pointer dcl 8 old_array_stcd_instruction internal static bit(36) initial packed unaligned dcl 8 pdl_ptr_types36 based structure array level 1 dcl 9-7 prog_frame defined pointer dcl 10-6 segment_chain based pointer dcl 8 size automatic fixed bin(17,0) dcl 8 star_rset defined fixed bin(71,0) dcl 10-45 string builtin function dcl 8 subr_block_head based structure level 1 dcl 14-3 subr_block_head_overlay based structure level 1 dcl 14-14 subr_entries based structure array level 1 dcl 14-32 t_atom_ptr based pointer dcl 10-6 tempp automatic pointer dcl 8 tsplp_ic_ind internal static bit(18) initial packed unaligned dcl 14-45 tsx0_ic internal static bit(18) initial packed unaligned dcl 14-45 tty_input_chan defined pointer dcl 10-6 tty_output_chan defined pointer dcl 10-6 ungc_element based fixed bin(71,0) dcl 8 ungclist_element based structure level 1 dcl 8 unwp_frame defined pointer dcl 10-6 NAMES DECLARED BY EXPLICIT CONTEXT. compute_total_allocation 000652 constant entry internal dcl 938 ref 148 341 934 gcsubr 000051 constant entry external dcl 119 join 000067 constant label dcl 123 ref 117 lisp_garbage_collector_ 000041 constant entry external dcl 6 set_gc_blk_cntr 000602 constant entry internal dcl 904 ref 342 935 set_gc_params 000571 constant entry external dcl 930 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1374 1520 677 1404 Length 2266 677 124 532 474 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME lisp_garbage_collector_ 168 external procedure is an external procedure. set_gc_blk_cntr internal procedure shares stack frame of external procedure lisp_garbage_collector_. compute_total_allocation internal procedure shares stack frame of external procedure lisp_garbage_collector_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME lisp_garbage_collector_ 000100 total_allocation lisp_garbage_collector_ 000101 old_allocation lisp_garbage_collector_ 000102 curseg lisp_garbage_collector_ 000104 curgcmark lisp_garbage_collector_ 000106 ungclist_ptr lisp_garbage_collector_ 000110 obarray_list lisp_garbage_collector_ 000112 obarray_list_end lisp_garbage_collector_ 000114 gcmode lisp_garbage_collector_ 000115 reti lisp_garbage_collector_ 000116 allocptr lisp_garbage_collector_ 000120 workptr lisp_garbage_collector_ 000122 stack lisp_garbage_collector_ 000124 start_time lisp_garbage_collector_ 000126 saved_alloc_fault_word lisp_garbage_collector_ 000127 fault_bits lisp_garbage_collector_ 000130 old_segs lisp_garbage_collector_ 000132 meter_time lisp_garbage_collector_ 000134 gc_time lisp_garbage_collector_ 000146 num_words_to_gc_at set_gc_blk_cntr THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_e_as call_ext_out_desc call_ext_out return_mac fl2_to_fx1 tra_ext_2 ext_entry divide_fx3 THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. hcs_$truncate_seg ioa_ lisp_$apply lisp_$eval lisp_alloc_$get_fault_word lisp_default_handler_$alloc_fault lisp_default_handler_$deferred_quit lisp_fault_handler_$nointerrupt lisp_gc_alm_$collect lisp_io_control_$gc_flush lisp_segment_manager_$free_lists lisp_special_fns_$cons lisp_special_fns_$ncons virtual_cpu_time_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. lisp_alloc_$alloc_fault_word lisp_alloc_$cur_seg lisp_alloc_$gc_blk_cntr lisp_static_vars_$activate_gc_unwinder_kludge lisp_static_vars_$cleanup_list lisp_static_vars_$cleanup_list_exists lisp_static_vars_$ctrlD lisp_static_vars_$garbage_collect_inhibit lisp_static_vars_$gc_mark_bits lisp_static_vars_$gc_time lisp_static_vars_$gc_unwinder_kludge lisp_static_vars_$gcmax lisp_static_vars_$gcmin lisp_static_vars_$gcmin_fraction lisp_static_vars_$gcsize lisp_static_vars_$i_am_gcing lisp_static_vars_$iochan_list lisp_static_vars_$nil lisp_static_vars_$space_names_atom lisp_static_vars_$stack_ptr lisp_static_vars_$status_gctwa lisp_static_vars_$t_atom lisp_static_vars_$unmkd_ptr lisp_static_vars_$user_intr_array LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 8 000030 6 000040 117 000047 119 000050 120 000057 121 000063 122 000065 123 000067 127 000072 128 000074 129 000077 130 000101 131 000103 137 000107 139 000116 141 000121 142 000124 146 000131 148 000140 149 000141 153 000143 154 000147 157 000150 159 000153 160 000155 163 000167 165 000174 171 000176 341 000212 342 000213 389 000214 390 000220 391 000222 393 000224 394 000227 395 000234 400 000247 401 000254 402 000256 403 000261 404 000270 411 000271 415 000302 416 000311 417 000320 419 000324 420 000336 421 000341 422 000350 430 000402 431 000407 432 000411 436 000415 437 000417 438 000422 439 000424 440 000425 443 000433 444 000437 445 000444 446 000451 447 000453 450 000455 451 000460 452 000467 454 000472 456 000500 457 000503 458 000505 459 000507 460 000513 462 000516 463 000524 464 000532 465 000536 466 000543 467 000550 468 000555 469 000562 472 000565 473 000567 930 000570 934 000577 935 000600 936 000601 904 000602 913 000603 916 000617 918 000623 923 000627 925 000651 938 000652 940 000653 941 000654 944 000664 945 000670 946 000673 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved