/* (C) Copyright International Business Machines Corporation 23 January */
/* 1990.  All Rights Reserved. */
/*  */
/* See the file USERAGREEMENT distributed with this software for full */
/* terms and conditions of use. */
/* File: o_proc.c */
/* Author: David F. Bacon */
#ifndef lint
static char sccsinfo[] = "@(#)o_proc.c	1.16 3/13/90";
#endif

#include <stdio.h>

#include "ops.h"
#include "storage.h"
#include "procenv.h"
#include "sysdep.h"
#include "accessors.h"
#include "recursiv.h"

#include "predefined.cd"
#include "interpform.cd"

#define Dst (DstObj->value)
#define Src (SrcObj->value)

extern datarep dr_inport, dr_outport, dr_procport, dr_program, dr_variant;


NILOP(o_endprocess)
{
    dfd_inport *make_inport();
    void fin_program(), re_finalize();
    void freepcb();

    pcb *deadproc;
    int i;
    dotcontainer *data;
    valcell ip;

    deadproc = args->sched->ready;
    /* Discard all objects in the data vector except LASTERROR */
    /* (because it may have a cheapcopy of a user exception or an exit */
    /* id from an LI prog as its value).  If this is the primary copy */
    /* of a procedure and the refcount is nonzero, we need to recreate */
    /* the init port in case another call comes in and reuses this */
    /* pcb. (Note that we cannot just keep the current initport, */
    /* because who knows what the terminating process just did to it!) */
    /* (Same reasoning says we shouldn't be keeping LASTERROR in the */
    /* data vector) */
    data = deadproc->ep.h;
    for (i = data->info.context->size - 1; i >= 0; i--)
      if (i is LASTERROR)
	continue;
      else
	if (not isbottom(&data->data[i]))
	  re_finalize(&data->data[i], F_DISCARD, args->sched);
    
    if (deadproc->type is ProcedurePrimaryUsed) {
				/* this pcb may be reused... reset it */
      if ((ip.inport = make_inport()) isnt nil) {
	data->data[INITPORT].value.inport = ip.inport;
	set_init(&data->data[INITPORT], dr_inport);
      }
      /* if the above fails, initport will be bottom and next call */
      /* will fail (see o_ports.c:procport_enq()) */
      
      /* primary pcb for this procedure is now free for re-use */
      deadproc->type = ProcedurePrimaryFree;
      args->nextop = 0;	/* reset the ip */
    }
    else
      /* discard aux structures for this pcb unless the pcb might be */
      /* re-used.  Can't discard pcb until it's been removed from */
      /* scheduler queues, so we leave that job for sched->kill() */
      freepcb(deadproc);

    /* deschedule the process and, unless it's the primary pcb for a */
    /* procedure, discard the pcb */
    args->sched->kill(args->sched, deadproc);
}


void
freepcb(p)
pcb *p;
{
    valcell progval;

    { freedotmain(p->ep.h->data[LASTERROR].value.variant, VARIANT_SIZE); }
    { freedotmain(p->ep.h, p->ep.h->info.context->size); }
				/* dispose the context */
    progval.program = p->prog;
    fin_program(progval, F_DISCARD, (schedblock *) nil);
				/* "discard" the program */

    /* fix later: what about nested contexts, suspend info??? */
}



NILOP(o_create)
{
    void re_finalize();
    pcb *do_create();
    pcb *newproc;
    extern flag cherm_flag;

    OPCHK(SrcObj,program);

    newproc = do_create(args);

    if (newproc) {
	newproc->type = Process;
	args->sched->add(args->sched, newproc);
        if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst.outport = dcdot(newproc->ep.h, INITPORT).inport;
	Dst.outport->refcount = 1; /* this is the first connection */
	set_init(DstObj, dr_outport);
    }
}


NILOP(o_procedure)
{
    void re_finalize();
    pcb *do_create();
    predef_exception procedure_enq();

    pcb *newproc;
    channel *chan;
    extern flag cherm_flag;

    OPCHK(SrcObj,program);

    newproc = do_create(args);
    
    if (newproc) {
	chan = new(channel);
	if (chan is nil) {
	    raise(Depletion);
	    return;
	}

	chan->type = LocalProcport;
	chan->refcount = 1;
	chan->port_enq = procedure_enq;
	chan->disconnected = FALSE;
	chan->info.procedure = newproc;

	newproc->type = ProcedurePrimaryFree;

	if (not cherm_flag)
	  re_finalize(DstObj, F_DISCARD, args->sched);
				/* finalize the value of the destination; */

	Dst.outport = chan;
	set_init(DstObj, dr_outport);
    }
}


static pcb *
do_create(args)
argblock *args;
{
    pcb *create_proc();
    status debug_level();

    pcb *newproc;
    valcell type;


    type = dot(dot(Src, program__LI_PROGRAM), prog__type);
				/* get the type of the program being created */

    if (not eq_record(type, args->qualifiers)) {
	raise(InterfaceMismatch); /* if type in qualifier doesn't match the */
				  /* program, raise exception */
#ifdef DEBUG
	if (debug_level(0))
	  (void) fprintf(stderr, "'%s' can't create '%s'.\n",
		  vstringval(dot(dcdot(args->sched->ready->prog, 
					  program__LI_PROGRAM), prog__name)),
		  vstringval(dot(dot(Src, program__LI_PROGRAM), prog__name)));
#endif DEBUG
	return(nil);
    }

    if ((newproc = create_proc(Src.program)) is nil)
      raise(Depletion);

    return(newproc);
}



pcb *
create_proc(proc)
pd_program *proc;
{
    dfd_inport *make_inport();
    void fin_inport();
    status prof_level();

    counter size;
    pcb *newproc = nil;
    context_info *contextinfo = nil;
    valcell ip;
    valcell lasterror;
    dotcontainer *procdata = nil;

    lasterror.variant = nil;
    ip.inport = nil;

    if (not refprog(proc))	/* try to bump the program refcount... */
      return(nil);		/*  ...and crap out if we can't */


				/* create a new process control block. */
    if ((newproc = new(pcb)) is nil) goto cleanup;
    size = dot(dcdot(proc, program__LI_PROGRAM), prog__size).integer;

				/* allocate the outer environment. */
    if ((procdata = getdotmain(size)) is nil) goto cleanup;
	
				/* allocate the struct for auxiliary info */
				/*  on this context. */
    if ((contextinfo = new(context_info)) is nil) goto cleanup;

    contextinfo->size = size; /* remember how big this context is. */
    contextinfo->estack = nil; /* empty exception stack. */
    contextinfo->previous = nil; /* a process has no previous context. */

				/* create the initport and set the typestate */
				/*  tag field. */
    if ((ip.inport = make_inport()) is nil) goto cleanup;

    /* make the LASTERROR variant.  we put it in case 'others' */
    /* first, which has an uninit value, so the bottom value */
    /* supplied by getdotmain() is fine. */
    if ((lasterror.variant = getdotmain(VARIANT_SIZE)) is nil) goto cleanup;
    lasterror.variant->info.variant_case = handler_type__others;

    /* now assemble all the pieces */
    cdr(newproc) = nil;	/* just a single process. */
    /* process type filled in by caller */
    newproc->interpreter = nil; /* use standard Hermes interpreter. */
    procdata->info.context = contextinfo;
    procdata->data[INITPORT].value = ip;
    procdata->data[INITPORT].tsdr = &dr_inport;
    procdata->data[LASTERROR].value = lasterror;
    procdata->data[LASTERROR].tsdr = &dr_variant;
    set_bottom(&procdata->data[CALLMESSAGE]);
    newproc->ep.h = procdata;
    newproc->ip = 0;	/* set the first instruction to run. */
    newproc->prog = proc;	/* "copy" the abstract program and L-I code */
    newproc->selecting = FALSE;
    /* suspend_info not set (not selecting, and not yet suspended) */
    /* refcount set by caller */
#ifdef TRACE
    newproc->call_level = 0;

    if (prof_level(1)) 
      create_profrec(newproc);
#endif
    return(newproc);

  cleanup:
    /* here when something failed... we need to release any storage we */
    /* allocated */
    if (newproc isnt nil)
      { dispose(newproc, pcb); }
    if (procdata isnt nil)
      { freedotmain(procdata, size); }
    if (contextinfo isnt nil)
      { dispose(contextinfo, context_info); }
    if (ip.inport isnt nil) 
      fin_inport(ip, F_DISCARD, (schedblock *) nil);
    if (lasterror.variant isnt nil)
      { freedotmain(lasterror.variant, VARIANT_SIZE); }
    return(nil);
}
