home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p1 / Runtime (.c & .h) / run.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-26  |  21.4 KB  |  869 lines  |  [TEXT/KAHL]
  1. /* Runtime stuff */
  2.  
  3. #include "params.h"
  4. #include "gambit.h"
  5. #include "struct.h"
  6. #include "os.h"
  7. #include "mem.h"
  8. #include "strings.h"
  9. #include "opcodes.h"
  10. #include "gc.h"
  11. #include "stats.h"
  12.  
  13.  
  14. /*---------------------------------------------------------------------------*/
  15.  
  16.  
  17. long read_not_ready;    /* index of '##exception.read-not-ready' var  */
  18. long write_not_ready;   /* index of '##exception.write-not-ready' var */
  19. long gc_finalize;       /* index of '##exception.gc-finalize' var     */
  20.  
  21.  
  22. /*---------------------------------------------------------------------------*/
  23.  
  24.  
  25. void print_global_var( name )
  26. char *name;
  27. { long index;
  28.   if (alloc_global( name, &index )) { os_warn( "%s\n", (long)os_err ); os_quit(); }
  29.   os_warn( "0x%x", sstate->globals[index].value );
  30.   os_warn( " = %s\n", (long)name );
  31. }
  32.  
  33.  
  34. /*---------------------------------------------------------------------------*/
  35.  
  36.  
  37. void if_prim( value, name, proc )
  38. SCM_obj value;
  39. SCM_obj name;
  40. void (*proc)();
  41. { if ((SCM_type(value) == SCM_type_PROCEDURE) &&
  42.       (SCM_header_procedure(SCM_header(value))))
  43.     (*proc)( SCM_object_adr(value), SCM_procedure_length(SCM_header(value)), string_to_c_str(name) );
  44. }
  45.  
  46.  
  47. void for_each_glob_prim_proc( proc )
  48. void (*proc)();
  49. { long i;
  50.   SCM_obj st = sstate->globals[SYMBOL_TABLE].value;
  51.   for (i=0; i<(long)SYMBOL_TABLE_LENGTH; i++)
  52.   { SCM_obj probe = SCM_obj_to_vect(st)[i];
  53.     while (probe != (long)SCM_null)
  54.     { SCM_obj sym = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj));
  55.       SCM_obj name = SCM_obj_to_vect(sym)[SYMBOL_NAME];
  56.       SCM_obj global = SCM_obj_to_vect(sym)[SYMBOL_GLOBAL];
  57.       if (global != (long)SCM_false)
  58.         if_prim( sstate->globals[SCM_obj_to_int(global)].value, name, proc );
  59.       probe = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj));
  60.     }
  61.   }
  62. }
  63.  
  64.  
  65. char *procedure_containing( pc )
  66. long pc;
  67. { long i;
  68.   SCM_obj st = sstate->globals[SYMBOL_TABLE].value;
  69.   for (i=0; i<(long)SYMBOL_TABLE_LENGTH; i++)
  70.   { SCM_obj probe = SCM_obj_to_vect(st)[i];
  71.     while (probe != (long)SCM_null)
  72.     { SCM_obj sym = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj));
  73.       SCM_obj name = SCM_obj_to_vect(sym)[SYMBOL_NAME];
  74.       SCM_obj global = SCM_obj_to_vect(sym)[SYMBOL_GLOBAL];
  75.       if (global != (long)SCM_false)
  76.       { SCM_obj value = sstate->globals[SCM_obj_to_int(global)].value;
  77.         if ((SCM_type(value) == SCM_type_PROCEDURE) &&
  78.             (SCM_header_procedure(SCM_header(value))) &&
  79.             (pc >= (long)SCM_object_adr(value)) &&
  80.             (pc <  ((long)SCM_object_adr(value))+SCM_procedure_length(SCM_header(value))))
  81.           return string_to_c_str( name );
  82.       }
  83.       probe = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj));
  84.     }
  85.   }
  86.   return NULL;
  87. }
  88.  
  89.  
  90. char *global_name( index )
  91. long index;
  92. { long i;
  93.   SCM_obj st = sstate->globals[SYMBOL_TABLE].value;
  94.   for (i=0; i<(long)SYMBOL_TABLE_LENGTH; i++)
  95.   { SCM_obj probe = SCM_obj_to_vect(st)[i];
  96.     while (probe != (long)SCM_null)
  97.     { SCM_obj sym = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj));
  98.       SCM_obj name = SCM_obj_to_vect(sym)[SYMBOL_NAME];
  99.       SCM_obj global = SCM_obj_to_vect(sym)[SYMBOL_GLOBAL];
  100.       if ((global != (long)SCM_false) && (SCM_obj_to_int( global ) == index))
  101.         return string_to_c_str( name );
  102.       probe = *(SCM_obj *)(probe-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj));
  103.     }
  104.   }
  105.   return NULL;
  106. }
  107.  
  108.  
  109. /*---------------------------------------------------------------------------*/
  110.  
  111. #define RAISE_OTHER_INTR(p,intr) { p->intr = 1; p->intr_other = 1; p->intr_flag = -1; }
  112.  
  113. #define WASTE_TIME() { register long count; for (count=10; count>0; count--) ; }
  114.  
  115.  
  116. long broadcast( send, msg1, msg2 )
  117. long send;
  118. long *msg1, *msg2;
  119. { long n = SCM_obj_to_int(pstate->nb_processors);
  120.   long id = SCM_obj_to_int(pstate->id);
  121.   long x = id*2+1, y = id*2+2;
  122.   long i;
  123.   long m1 = *msg1, m2 = *msg2;
  124.   if (send) i = id; else i = -1;
  125.   if (x < n)
  126.   { while (pstate->sync1 == -2) WASTE_TIME();
  127.     if (i == -1)
  128.     { i = pstate->sync1; m1 = pstate->sync1_msg1; m2 = pstate->sync1_msg2; }
  129.     pstate->sync1 = -2;
  130.     if (y < n)
  131.     { while (pstate->sync2 == -2) WASTE_TIME();
  132.       if (i == -1)
  133.       { i = pstate->sync2; m1 = pstate->sync2_msg1; m2 = pstate->sync2_msg2; }
  134.       pstate->sync2 = -2;
  135.     }
  136.   }
  137.   if (id == 0)
  138.   { pstate->sync0_msg1 = m1; pstate->sync0_msg2 = m2; pstate->sync0 = i; }
  139.   else
  140.   { PSTATE_PTR parent = pstate->ps[(id-1)/2];
  141.     pstate->sync0 = -2;
  142.     if (id & 1)
  143.     { parent->sync1_msg1 = m1; parent->sync1_msg2 = m2; parent->sync1 = i; }
  144.     else
  145.     { parent->sync2_msg1 = m1; parent->sync2_msg2 = m2; parent->sync2 = i; }
  146.     while (pstate->sync0 == -2) WASTE_TIME();
  147.   }
  148.   if (x < n)
  149.   { PSTATE_PTR child1 = pstate->ps[x];
  150.     child1->sync0_msg1 = pstate->sync0_msg1;
  151.     child1->sync0_msg2 = pstate->sync0_msg2;
  152.     child1->sync0      = pstate->sync0;
  153.     if (y < n)
  154.     { PSTATE_PTR child2 = pstate->ps[y];
  155.       child2->sync0_msg1 = pstate->sync0_msg1;
  156.       child2->sync0_msg2 = pstate->sync0_msg2;
  157.       child2->sync0      = pstate->sync0;
  158.     }
  159.   }
  160.   *msg1 = pstate->sync0_msg1;
  161.   *msg2 = pstate->sync0_msg2;
  162.   return pstate->sync0;
  163. }
  164.  
  165.  
  166. void barrier( name )
  167. char *name;
  168. { long msg1, msg2;
  169.   if (broadcast( 0L, &msg1, &msg2 ) >= 0)
  170.   { os_warn( "Processors out of sync at barrier %s\n", (long)name ); os_quit(); }
  171. }
  172.  
  173.  
  174. void barrier_trigger()
  175. { long i;
  176.   for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  177.   { PSTATE_PTR p = pstate->ps[i];
  178.     if (p != pstate) RAISE_OTHER_INTR(p,intr_barrier);
  179.   }
  180. }
  181.  
  182.  
  183. long barrier_call( proc, arg )
  184. long (*proc)();
  185. long arg;
  186. { long (*proc2)();
  187.   long arg2;
  188.   long result;
  189.   long id;
  190.   do
  191.   { proc2 = *proc;
  192.     arg2  = arg;
  193.     barrier_trigger();
  194.     id = broadcast( 1L, (long *)&proc2, &arg2 );
  195.     pstate->intr_barrier = 0;
  196.     barrier( "BARRIER_CALL" );
  197.     result = proc2( id, arg2 );
  198.   } while (id != SCM_obj_to_int(pstate->id) );
  199.   return result;
  200. }
  201.  
  202.  
  203. long barrier_service()
  204. { long (*proc2)();
  205.   long arg2;
  206.   long id;
  207.   id = broadcast( 0L, (long *)&proc2, &arg2 );
  208.   if (id < 0)
  209.   { os_warn( "Processors out of sync at a barrier\n", 0L ); os_quit(); }
  210.   pstate->intr_barrier = 0;
  211.   barrier( "BARRIER_SERVICE" );
  212.   return proc2( id, arg2 );
  213. }
  214.  
  215.  
  216. /*---------------------------------------------------------------------------*/
  217.  
  218.  
  219. long do_return( id, arg )
  220. long id;
  221. long arg;
  222. { return arg;
  223. }
  224.  
  225.  
  226. long do_cpu_times( id, arg )
  227. long id;
  228. long arg;
  229. { os_cpu_times( pstate->cpu_times );
  230.   barrier( "DO_CPU_TIMES" );
  231.   return 0;
  232. }
  233.  
  234.  
  235. long do_gc( id, arg )
  236. long id;
  237. long arg;
  238. { gc();
  239.   os_flush_caches();
  240.   return 0;
  241. }
  242.  
  243.  
  244. long do_load_ofile( id, filename )
  245. long id;
  246. char *filename;
  247. { SCM_obj result;
  248.   if (SCM_obj_to_int(pstate->id) == id)
  249.   { sstate->program_filename = filename;
  250.     load_ofile( filename, &result );
  251.   }
  252.   else
  253.     load_ofile( (char *)NULL, &result );
  254.   barrier( "DO_LOAD_OFILE" );
  255.   os_flush_caches();
  256.   return result;
  257. }
  258.  
  259.  
  260. long do_set_timer_interval( id, arg )
  261. long id;
  262. long arg;
  263. { if (SCM_obj_to_int(pstate->id) == 0)
  264.     os_set_timer_interval( arg );
  265.   return 0;
  266. }
  267.  
  268.  
  269. /*---------------------------------------------------------------------------*/
  270.  
  271. /* Interrupt handling */
  272.  
  273.  
  274. void user_intr_proc( pc, sp, kind )
  275. long pc, sp;
  276. char *kind;
  277. { RAISE_OTHER_INTR(pstate,intr_user);
  278. }
  279.  
  280.  
  281. void timer_intr_proc( pc, sp, kind )
  282. long pc, sp;
  283. long kind;
  284. { long i;
  285.   for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  286.     RAISE_OTHER_INTR(pstate->ps[i],intr_timer);
  287. }
  288.  
  289.  
  290. void io_intr_proc( pc, sp, kind )
  291. long pc, sp;
  292. long kind;
  293. { RAISE_OTHER_INTR(pstate,intr_io);
  294. }
  295.  
  296.  
  297. void fatal_intr_proc( pc, sp, kind )
  298. long pc, *sp;
  299. char *kind;
  300. { char *name;
  301.   os_warn( "Processor %d", SCM_obj_to_int(pstate->id) );
  302.   os_warn( " raised signal %s ", (long)kind );
  303.   if (pc != 0)
  304.   { os_warn( "at PC=0x%x", pc );
  305.     name = procedure_containing( pc );
  306.     if (name != NULL) os_warn( " in %s", (long)name );
  307.   }
  308.   os_warn( "\n", 0L );
  309.   if (sp != NULL)
  310.   { int i;
  311.     os_warn( "Stack dump:\n", 0L );
  312.     for (i=0; i<16; i++)
  313.     { long value = sp[i];
  314.       os_warn( "  [0x%x] = ", (long)&sp[i] );
  315.       os_warn( "0x%x", value );
  316.       if (SCM_type(value) == SCM_type_PROCEDURE)
  317.       { name = procedure_containing( value );
  318.         if (name != NULL) os_warn( " in %s", (long)name );
  319.       }
  320.       os_warn( "\n", 0L );
  321.     }
  322.   }      
  323.   os_quit();
  324. }
  325.  
  326.  
  327. /*---------------------------------------------------------------------------*/
  328.  
  329. /* Scheme procedures written in C */
  330.  
  331.  
  332. SCM_obj X23X23gc()
  333. { barrier_call( do_gc, 0L );
  334.   *(pstate->stack_ptr) = sstate->globals[gc_finalize].value;
  335.   return (long)SCM_false;
  336. }
  337.  
  338.  
  339. SCM_obj X23X23barrier()
  340. { barrier_service();
  341.   return (long)SCM_false;
  342. }
  343.  
  344.  
  345. SCM_obj X23X23quit( num )
  346. SCM_obj num;
  347. { os_quit();
  348. }
  349.  
  350.  
  351. OS_FILE file[MAX_NB_OPEN_FILES];
  352.  
  353.  
  354. SCM_obj X23X23osDfileDopenDinput( path )
  355. SCM_obj path;
  356. { char *filename, *mark;
  357.   SCM_obj result;
  358.   long i;
  359.   for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) if (file[i] == -1) break;
  360.   if (i == (long)MAX_NB_OPEN_FILES) return (long)SCM_false;
  361.   mark = local_mark();
  362.   filename = os_expand_filename( string_to_c_str(path) );
  363.   if (filename == NULL)
  364.     result = (long)SCM_false;
  365.   else
  366.   { OS_FILE f = os_file_open_input( filename );
  367.     if (f == -1)
  368.       result = (long)SCM_false;
  369.     else
  370.     { file[i] = f;
  371.       result = SCM_int_to_obj(i);
  372.     }
  373.   }
  374.   local_release( mark );
  375.   return result;
  376. }
  377.  
  378.  
  379. SCM_obj X23X23osDfileDopenDoutput( path )
  380. SCM_obj path;
  381. { char *filename, *mark;
  382.   SCM_obj result;
  383.   long i;
  384.   for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) if (file[i] == -1) break;
  385.   if (i == (long)MAX_NB_OPEN_FILES) return (long)SCM_false;
  386.   mark = local_mark();
  387.   filename = os_expand_filename( string_to_c_str(path) );
  388.   if (filename == NULL)
  389.     result = (long)SCM_false;
  390.   else
  391.   { OS_FILE f = os_file_open_output( filename );
  392.     if (f == -1)
  393.       result = (long)SCM_false;
  394.     else
  395.     { file[i] = f;
  396.       result = SCM_int_to_obj(i);
  397.     }
  398.   }
  399.   local_release( mark );
  400.   return result;
  401. }
  402.  
  403.  
  404. SCM_obj X23X23osDfileDopenDinputDoutput( path )
  405. SCM_obj path;
  406. { char *filename, *mark;
  407.   SCM_obj result;
  408.   long i;
  409.   for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) if (file[i] == -1) break;
  410.   if (i == (long)MAX_NB_OPEN_FILES) return (long)SCM_false;
  411.   mark = local_mark();
  412.   filename = os_expand_filename( string_to_c_str(path) );
  413.   if (filename == NULL)
  414.     result = (long)SCM_false;
  415.   else
  416.   { OS_FILE f = os_file_open_input_output( filename );
  417.     if (f == -1)
  418.       result = (long)SCM_false;
  419.     else
  420.     { file[i] = f;
  421.       result = SCM_int_to_obj(i);
  422.     }
  423.   }
  424.   local_release( mark );
  425.   return result;
  426. }
  427.  
  428.  
  429. SCM_obj X23X23osDfileDclose( ind )
  430. SCM_obj ind;
  431. { long i = SCM_obj_to_int(ind);
  432.   if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  433.   { OS_FILE f = file[i];
  434.     if (f != -1)
  435.       if (os_file_close( f ) != -1) 
  436.       { if (i>=3) file[i] = -1;
  437.         return (long)SCM_true;
  438.       }
  439.   }
  440.   return (long)SCM_false;
  441. }
  442.  
  443.  
  444. SCM_obj X23X23osDfileDreadDready( ind )
  445. SCM_obj ind;
  446. { long i = SCM_obj_to_int(ind);
  447.   if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  448.   { OS_FILE f = file[i];
  449.     if ((f != -1) && os_file_read_ready( f ))
  450.       return (long)SCM_true;
  451.   }
  452.   return (long)SCM_false;
  453. }
  454.  
  455.  
  456. SCM_obj X23X23osDfileDread( ind, buf, start, end  )
  457. SCM_obj ind, buf, start, end;
  458. { long i = SCM_obj_to_int(ind);
  459.   long s = SCM_obj_to_int(start);
  460.   if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  461.   { OS_FILE f = file[i];
  462.     if (f != -1)
  463.     { long result = os_file_read( f,
  464.                                   SCM_obj_to_str(buf) + s,
  465.                                   SCM_obj_to_int(end) - s );
  466.       if (result >= 0)
  467.         return SCM_int_to_obj( result );
  468.       else if (result == -2) /* not ready? */
  469.       { *(pstate->stack_ptr) = sstate->globals[read_not_ready].value;
  470.         return ind;
  471.       }
  472.     }
  473.   }
  474.   return (long)SCM_false;
  475. }
  476.  
  477.  
  478. SCM_obj X23X23osDfileDwrite( ind, buf, start, end  )
  479. SCM_obj ind, buf, start, end;
  480. { long i = SCM_obj_to_int(ind);
  481.   long s = SCM_obj_to_int(start);
  482.   if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  483.   { OS_FILE f = file[i];
  484.     if (f != -1)
  485.     { long result = os_file_write( f,
  486.                                     SCM_obj_to_str(buf) + s,
  487.                                     SCM_obj_to_int(end) - s );
  488.       if (result >= 0)
  489.         return SCM_int_to_obj( result );
  490.       else if (result == -2) /* not ready? */
  491.       { *(pstate->stack_ptr) = sstate->globals[write_not_ready].value;
  492.         return ind;
  493.       }
  494.     }
  495.   }
  496.   return (long)SCM_false;
  497. }
  498.  
  499.  
  500. SCM_obj X23X23osDfileDblockDread( ind )
  501. SCM_obj ind;
  502. { long i = SCM_obj_to_int(ind);
  503.   if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  504.   { OS_FILE f = file[i];
  505.     if (f != -1) os_file_block_read( f );
  506.   }
  507.   return (long)SCM_false;
  508. }
  509.  
  510.  
  511. SCM_obj X23X23osDfileDblockDwrite( ind )
  512. SCM_obj ind;
  513. { long i = SCM_obj_to_int(ind);
  514.   if ((i>=0) && (i<(long)MAX_NB_OPEN_FILES))
  515.   { OS_FILE f = file[i];
  516.     if (f != -1) os_file_block_write( f );
  517.   }
  518.   return (long)SCM_false;
  519. }
  520.  
  521.  
  522. SCM_obj X23X23osDsetDtimerDinterval( interval )
  523. SCM_obj interval;
  524. { barrier_call( do_set_timer_interval, SCM_obj_to_int( interval ) );
  525.   return (long)SCM_false;
  526. }
  527.  
  528.  
  529. SCM_obj X23X23osDgetDnextDevent()
  530. { long len = ceiling8(sizeof(SCM_obj)+OS_EVENT_SIZE);
  531.   if ((pstate->heap_ptr - pstate->heap_lim) < len)
  532.   { barrier_call( do_gc, 0L );
  533.     *(pstate->stack_ptr) = sstate->globals[gc_finalize].value;
  534.     return (long)SCM_false;  /* finalization prevents returning an event */
  535.   }
  536.   pstate->heap_ptr -= len;
  537.   if (os_get_next_event( pstate->heap_ptr+sizeof(SCM_obj) ))
  538.   { *(long *)(pstate->heap_ptr) = SCM_make_header( (long)OS_EVENT_SIZE, SCM_subtype_STRING );
  539.     return (SCM_obj)(pstate->heap_ptr + SCM_type_SUBTYPED);
  540.   }
  541.   else
  542.   { pstate->heap_ptr += len;
  543.     return (long)SCM_false;
  544.   }
  545. }
  546.  
  547.  
  548. SCM_obj X23X23osDhandleDevent( event )
  549. SCM_obj event;
  550. { if (os_handle_event( event-SCM_type_SUBTYPED+sizeof(SCM_obj) ))
  551.     return (long)SCM_true;
  552.   else
  553.     return (long)SCM_false;
  554. }
  555.  
  556.  
  557. SCM_obj X23X23cpuDtimes( buf )
  558. SCM_obj buf;
  559. { long ucpu = 0, scpu = 0;
  560.   long i;
  561.   barrier_call( do_cpu_times, 0L );
  562.   for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  563.   { PSTATE_PTR p = pstate->ps[i];
  564.     ucpu += p->cpu_times[0];
  565.     scpu += p->cpu_times[1];
  566.   }
  567.   SCM_obj_to_vect(buf)[0] = SCM_int_to_obj( ucpu / SCM_obj_to_int(pstate->nb_processors) );
  568.   SCM_obj_to_vect(buf)[1] = SCM_int_to_obj( scpu / SCM_obj_to_int(pstate->nb_processors) );
  569.   return buf;
  570. }
  571.  
  572.  
  573. SCM_obj X23X23realDtime()
  574. { return SCM_int_to_obj( os_clock_to_msec( os_clock() ) );
  575. }
  576.  
  577.  
  578. SCM_obj X23X23loadDobjectDfile( path )
  579. SCM_obj path;
  580. { SCM_obj result;
  581.   char *filename1 = os_expand_filename( string_to_c_str(path) );
  582.   char *mark = local_mark();
  583.   char *filename2 = string_append( filename1, ".O" );
  584.   if (filename2 == NULL)
  585.     result = (long)SCM_false;
  586.   else
  587.   { OS_FILE f = os_file_open_input( filename2 );
  588.     if (f == -1)
  589.       result = (long)SCM_false;
  590.     else
  591.     { long len = os_file_length( f );
  592.       os_file_close( f );
  593.       if (len < 0)
  594.         result = (long)SCM_false;
  595.       else
  596.       { if ((pstate->heap_ptr - pstate->heap_lim) < 2*len)
  597.         { barrier_call( do_gc, 0L );
  598.           *(pstate->stack_ptr) = sstate->globals[gc_finalize].value;
  599.         }
  600.         result = barrier_call( do_load_ofile, (long)filename1 );
  601.       }
  602.     }
  603.   }
  604.   local_release( mark );
  605.   return result;
  606. }
  607.  
  608.  
  609. long do_copy_constant( id, obj )
  610. long id;
  611. SCM_obj obj;
  612. { SCM_obj *p1 = SCM_object_adr( obj ), *p2;
  613.   long obj_type = SCM_type( obj );
  614.   if (obj_type == SCM_type_PAIR)
  615.   { p2 = (SCM_obj *)sstate->const_tptr;
  616.     p2[0] = p1[0];
  617.     p2[1] = p1[1];
  618.   }
  619.   else
  620.   { long len = ceiling8(SCM_length(obj)+sizeof(SCM_obj))/sizeof(SCM_obj);
  621.     p2 = ((SCM_obj *)sstate->const_bptr) - len;
  622.     os_block_copy( (char *)p1, (char *)p2, len*sizeof(SCM_obj) );
  623.   }
  624.   return SCM_add_type( p2, obj_type );
  625. }
  626.  
  627.  
  628. long do_local_copy( id, obj )
  629. long id;
  630. SCM_obj obj;
  631. { SCM_obj result;
  632.   if (SCM_obj_to_int(pstate->id) == id)
  633.   { long obj_type = SCM_type( obj );
  634.     long len;
  635.     if (obj_type == SCM_type_PAIR)
  636.       len = 2;
  637.     else
  638.       len = ceiling8(SCM_length(obj)+sizeof(SCM_obj))/sizeof(SCM_obj);
  639.     if ((len*sizeof(SCM_obj)) > (sstate->const_tptr-sstate->const_bptr))
  640.       result = barrier_call( do_return, (long)SCM_false );
  641.     else
  642.     { if (obj_type == SCM_type_PAIR)
  643.         sstate->const_tptr -= len*sizeof(SCM_obj);
  644.       else
  645.         sstate->const_bptr += len*sizeof(SCM_obj);
  646.       result = barrier_call( do_copy_constant, (long)obj );
  647.     }
  648.   }
  649.   else
  650.     result = barrier_service();
  651.   return result;
  652. }
  653.  
  654.  
  655. SCM_obj X23X23localDcopy( obj )
  656. SCM_obj obj;
  657. { long obj_type = SCM_type( obj );
  658.   if ((obj_type == SCM_type_FIXNUM) ||
  659.       (obj_type == SCM_type_SPECIAL) ||
  660.       (obj_type == SCM_type_PLACEHOLDER)) /* don't copy placeholders... */
  661.     return obj;
  662.   else
  663.     return barrier_call( do_local_copy, (long)obj );
  664. }
  665.  
  666.  
  667. long do_make_distributed_pair_chain( id, n )
  668. long id;
  669. long n;
  670. { SCM_obj result = (long)SCM_false;
  671.   if (SCM_obj_to_int(pstate->id) == id)
  672.   { long i = n-1;
  673.     while (i >= 0)  /* warning: heap overflow checks not done... */
  674.     { long *ptr;
  675.       PSTATE_PTR p = pstate->ps[i%SCM_obj_to_int(pstate->nb_processors)];
  676.       p->heap_ptr -= 2*sizeof(SCM_obj);
  677.       ptr = (SCM_obj *)p->heap_ptr;
  678.       ptr[0] = result;
  679.       ptr[1] = SCM_false;
  680.       result = SCM_add_type( ptr, SCM_type_PAIR );
  681.       i--;
  682.     }
  683.     barrier_call( do_return, result );
  684.   }
  685.   else
  686.     result = barrier_service();
  687.   return result;
  688. }
  689.  
  690.  
  691. SCM_obj X23X23makeDdistributedDpairDchain( len )
  692. SCM_obj len;
  693. { return barrier_call( do_make_distributed_pair_chain, SCM_obj_to_int( len ) );
  694. }
  695.  
  696.  
  697. long do_make_distributed_vector_chain( id, n_m )
  698. long id;
  699. long n_m;
  700. { SCM_obj result = (long)SCM_false;
  701.   long n = n_m >> 8;
  702.   long m = n_m & ((1 << 8) - 1);
  703.   long size1 = m*sizeof(SCM_obj);
  704.   long size2 = ceiling8(sizeof(SCM_obj)+size1);
  705.   if (SCM_obj_to_int(pstate->id) == id)
  706.   { long i = n-1;
  707.     while (i >= 0)  /* warning: heap overflow checks not done... */
  708.     { long *ptr;
  709.       long j;
  710.       PSTATE_PTR p = pstate->ps[i%SCM_obj_to_int(pstate->nb_processors)];
  711.       p->heap_ptr -= size2;
  712.       ptr = (SCM_obj *)p->heap_ptr;
  713.       ptr[0] = SCM_make_header( size1, SCM_subtype_VECTOR );
  714.       for (j=m; j>0; j--) ptr[j] = SCM_false;
  715.       ptr[1] = result;
  716.       result = SCM_add_type( ptr, SCM_type_SUBTYPED );
  717.       i--;
  718.     }
  719.     barrier_call( do_return, result );
  720.   }
  721.   else
  722.     result = barrier_service();
  723.   return result;
  724. }
  725.  
  726.  
  727. SCM_obj X23X23makeDdistributedDvectorDchain( len, size )
  728. SCM_obj len, size;
  729. { return barrier_call( do_make_distributed_vector_chain, (SCM_obj_to_int( len )<<8)+SCM_obj_to_int( size ) );
  730. }
  731.  
  732.  
  733. long do_stats_start( id, arg )
  734. long id;
  735. long arg;
  736. { stats_start1( id );
  737.   barrier( "DO_STATS_START" );
  738.   return 0;
  739. }
  740.  
  741.  
  742. long do_stats_stop( id, arg )
  743. long id;
  744. long arg;
  745. { barrier( "DO_STATS_STOP1" );
  746.   stats_stop2();
  747.   barrier( "DO_STATS_STOP2" );
  748.   return 0;
  749. }
  750.  
  751.  
  752. SCM_obj X23X23statsDstart()
  753. { barrier_call( do_stats_start, 0L );
  754.   stats_start2();
  755.   return (long)SCM_true;
  756. }
  757.  
  758.  
  759. SCM_obj X23X23statsDstop()
  760. { long result = SCM_int_to_obj( stats_stop1() );
  761.   barrier_call( do_stats_stop, 0L );
  762.   return result;
  763. }
  764.  
  765.  
  766. SCM_obj X23X23fatalDheapDoverflow()
  767. { os_warn( "*** ERROR -- Fatal heap overflow, terminating...\n", 0L ); os_quit();
  768. }
  769.  
  770.  
  771. /*---------------------------------------------------------------------------*/
  772.  
  773.  
  774. void init_runtime()
  775. { long i;
  776.  
  777.   for (i=0; i<(long)MAX_NB_OPEN_FILES; i++) file[i] = -1;
  778.  
  779.   file[0] = os_stdin;
  780.   file[1] = os_stdout;
  781.   file[2] = os_stderr;
  782.  
  783.   DEFINE_C_PROC(X23X23gc);
  784.   DEFINE_C_PROC(X23X23barrier);
  785.   DEFINE_C_PROC(X23X23quit);
  786.   DEFINE_C_PROC(X23X23osDfileDopenDinput);
  787.   DEFINE_C_PROC(X23X23osDfileDopenDoutput);
  788.   DEFINE_C_PROC(X23X23osDfileDopenDinputDoutput);
  789.   DEFINE_C_PROC(X23X23osDfileDclose);
  790.   DEFINE_C_PROC(X23X23osDfileDreadDready);
  791.   DEFINE_C_PROC(X23X23osDfileDread);
  792.   DEFINE_C_PROC(X23X23osDfileDwrite);
  793.   DEFINE_C_PROC(X23X23osDfileDblockDread);
  794.   DEFINE_C_PROC(X23X23osDfileDblockDwrite);
  795.   DEFINE_C_PROC(X23X23osDsetDtimerDinterval);
  796.   DEFINE_C_PROC(X23X23osDgetDnextDevent);
  797.   DEFINE_C_PROC(X23X23osDhandleDevent);
  798.   DEFINE_C_PROC(X23X23cpuDtimes);
  799.   DEFINE_C_PROC(X23X23realDtime);
  800.   DEFINE_C_PROC(X23X23loadDobjectDfile);
  801.   DEFINE_C_PROC(X23X23localDcopy);
  802.   DEFINE_C_PROC(X23X23makeDdistributedDpairDchain);
  803.   DEFINE_C_PROC(X23X23makeDdistributedDvectorDchain);
  804.   DEFINE_C_PROC(X23X23statsDstart);
  805.   DEFINE_C_PROC(X23X23statsDstop);
  806.   DEFINE_C_PROC(X23X23fatalDheapDoverflow);
  807.  
  808.   /* setup OS specific extensions */
  809.  
  810.   ext_init();
  811.  
  812.   /* setup other globals */
  813.  
  814.   if (alloc_global( "##gc-report", &gc_report )) os_quit();
  815.   if (set_global( "##gc-report", (long)SCM_false )) os_quit();
  816.   if (alloc_global( "##exception.read-not-ready", &read_not_ready )) os_quit();
  817.   if (alloc_global( "##exception.write-not-ready", &write_not_ready )) os_quit();
  818.   if (alloc_global( "##exception.gc-finalize", &gc_finalize )) os_quit();
  819. }
  820.  
  821.  
  822. /*---------------------------------------------------------------------------*/
  823.  
  824.  
  825. void stop()
  826. { /* can be used as a breakpoint for debugging */
  827. }
  828.  
  829.  
  830. void start_program( kernel )
  831. void (*kernel)();
  832. {
  833.   /* start processors */
  834.  
  835.   if (sstate->debug>=1)
  836.     os_warn( "Starting %d processor(s)\n", SCM_obj_to_int(pstate->nb_processors) );
  837.  
  838.   if (sstate->debug>=1)
  839.     os_install_trap_handlers( user_intr_proc, timer_intr_proc, io_intr_proc, (void (*)())0 );
  840.   else
  841.     os_install_trap_handlers( user_intr_proc, timer_intr_proc, io_intr_proc, fatal_intr_proc );
  842.  
  843.   os_flush_caches();
  844.  
  845.   pstate = pstate->ps[ os_fork_on_processors( SCM_obj_to_int(pstate->nb_processors) ) ];
  846.  
  847.  
  848.   /* wait until all processors are ready to go */
  849.  
  850.   barrier( "STARTUP" );
  851.  
  852.  
  853.   /* setup processor state */
  854.  
  855.   if (sstate->debug>=1)
  856.     os_warn( "Starting processor %d\n", SCM_obj_to_int(pstate->id) );
  857.  
  858.   pstate->flush_writes = os_flush_writes;
  859.  
  860.   if (SCM_obj_to_int(pstate->id) == 0) X23X23statsDstart();
  861.  
  862.   stop();  (*kernel)( table, pstate, os_M68881 );
  863.  
  864.   if (SCM_obj_to_int(pstate->id) == 0) X23X23statsDstop();
  865. }
  866.  
  867.  
  868. /*---------------------------------------------------------------------------*/
  869.