tcl/unix/tclLoadAout.c

   1 /*
   2  * tclLoadAout.c --
   3  *
   4  *      This procedure provides a version of the TclLoadFile that
   5  *      provides pseudo-static linking using version-7 compatible
   6  *      a.out files described in either sys/exec.h or sys/a.out.h.
   7  *
   8  * Copyright (c) 1995, by General Electric Company. All rights reserved.
   9  *
  10  * See the file "license.terms" for information on usage and redistribution
  11  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12  *
  13  * This work was supported in part by the ARPA Manufacturing Automation
  14  * and Design Engineering (MADE) Initiative through ARPA contract
  15  * F33615-94-C-4400.
  16  *
  17  * RCS: @(#) $Id$
  18  */
  19
  20 #include "tclInt.h"
  21 #include <fcntl.h>
  22 #ifdef HAVE_EXEC_AOUT_H
  23 #   include <sys/exec_aout.h>
  24 #endif
  25 #ifdef HAVE_UNISTD_H
  26 #   include <unistd.h>
  27 #else
  28 #   include "../compat/unistd.h"
  29 #endif
  30
  31 /*
  32  * Some systems describe the a.out header in sys/exec.h, and some in
  33  * a.out.h.
  34  */
  35
  36 #ifdef USE_SYS_EXEC_H
  37 #include <sys/exec.h>
  38 #endif
  39 #ifdef USE_A_OUT_H
  40 #include <a.out.h>
  41 #endif
  42 #ifdef USE_SYS_EXEC_AOUT_H
  43 #include <sys/exec_aout.h>
  44 #define a_magic a_midmag
  45 #endif
  46
  47 /*
  48  * TCL_LOADSHIM is the amount by which to shim the break when loading
  49  */
  50
  51 #ifndef TCL_LOADSHIM
  52 #define TCL_LOADSHIM 0x4000L
  53 #endif
  54
  55 /*
  56  * TCL_LOADALIGN must be a power of 2, and is the alignment to which
  57  * to force the origin of load modules
  58  */
  59
  60 #ifndef TCL_LOADALIGN
  61 #define TCL_LOADALIGN 0x4000L
  62 #endif
  63
  64 /*
  65  * TCL_LOADMAX is the maximum size of a load module, and is used as
  66  * a sanity check when loading
  67  */
  68
  69 #ifndef TCL_LOADMAX
  70 #define TCL_LOADMAX 2000000L
  71 #endif
  72
  73 /*
  74  * Kernel calls that appear to be missing from the system .h files:
  75  */
  76
  77 extern char * brk _ANSI_ARGS_((char *));
  78 extern char * sbrk _ANSI_ARGS_((size_t));
  79
  80 /*
  81  * The static variable SymbolTableFile contains the file name where the
  82  * result of the last link was stored.  The file is kept because doing so
  83  * allows one load module to use the symbols defined in another.
  84  */
  85
  86 static char * SymbolTableFile = NULL;
  87
  88 /*
  89  * Type of the dictionary function that begins each load module.
  90  */
  91
  92 typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((CONST char * symbol));
  93
  94 /*
  95  * Prototypes for procedures referenced only in this file:
  96  */
  97
  98 static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr,
  99                                       Tcl_DString * buf));
 100 static void UnlinkSymbolTable _ANSI_ARGS_((void));
 101 \f
 102 /*
 103  *----------------------------------------------------------------------
 104  *
 105  * TclpDlopen --
 106  *
 107  *      Dynamically loads a binary code file into memory and returns
 108  *      a handle to the new code.
 109  *
 110  * Results:
 111  *      A standard Tcl completion code.  If an error occurs, an error
 112  *      message is left in the interp's result.
 113  *
 114  * Side effects:
 115  *      New code suddenly appears in memory.
 116  *
 117  *
 118  * Bugs:
 119  *      This function does not attempt to handle the case where the
 120  *      BSS segment is not executable.  It will therefore fail on
 121  *      Encore Multimax, Pyramid 90x, and similar machines.  The
 122  *      reason is that the mprotect() kernel call, which would
 123  *      otherwise be employed to mark the newly-loaded text segment
 124  *      executable, results in a system crash on BSD/386.
 125  *
 126  *      In an effort to make it fast, this function eschews the
 127  *      technique of linking the load module once, reading its header
 128  *      to determine its size, allocating memory for it, and linking
 129  *      it again.  Instead, it `shims out' memory allocation by
 130  *      placing the module TCL_LOADSHIM bytes beyond the break,
 131  *      and assuming that any malloc() calls required to run the
 132  *      linker will not advance the break beyond that point.  If
 133  *      the break is advanced beyonnd that point, the load will
 134  *      fail with an `inconsistent memory allocation' error.
 135  *      It perhaps ought to retry the link, but the failure has
 136  *      not been observed in two years of daily use of this function.
 137  *----------------------------------------------------------------------
 138  */
 139
 140 int
 141 TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
 142     Tcl_Interp *interp;         /* Used for error reporting. */
 143     Tcl_Obj *pathPtr;           /* Name of the file containing the desired
 144                                  * code (UTF-8). */
 145     Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
 146                                  * file which will be passed back to
 147                                  * (*unloadProcPtr)() to unload the file. */
 148     Tcl_FSUnloadFileProc **unloadProcPtr;
 149                                 /* Filled with address of Tcl_FSUnloadFileProc
 150                                  * function which should be used for
 151                                  * this file. */
 152 {
 153     char * inputSymbolTable;    /* Name of the file containing the
 154                                  * symbol table from the last link. */
 155     Tcl_DString linkCommandBuf; /* Command to do the run-time relocation
 156                                  * of the module.*/
 157     char * linkCommand;
 158     char relocatedFileName [L_tmpnam];
 159                                 /* Name of the file holding the relocated */
 160                                 /* text of the module */
 161     int relocatedFd;            /* File descriptor of the file holding
 162                                  * relocated text */
 163     struct exec relocatedHead;  /* Header of the relocated text */
 164     unsigned long relocatedSize;/* Size of the relocated text */
 165     char * startAddress;        /* Starting address of the module */
 166     int status;                 /* Status return from Tcl_ calls */
 167     char * p;
 168
 169     /* Find the file that contains the symbols for the run-time link. */
 170
 171     if (SymbolTableFile != NULL) {
 172         inputSymbolTable = SymbolTableFile;
 173     } else if (tclExecutableName == NULL) {
 174         Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC);
 175         return TCL_ERROR;
 176     } else {
 177         inputSymbolTable = tclExecutableName;
 178     }
 179
 180     /* Construct the `ld' command that builds the relocated module */
 181
 182     tmpnam (relocatedFileName);
 183     Tcl_DStringInit (&linkCommandBuf);
 184     Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1);
 185     Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1);
 186 #if defined(__mips) || defined(mips)
 187     Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1);
 188 #endif
 189     Tcl_DStringAppend (&linkCommandBuf, " -u TclLoadDictionary_", -1);
 190     TclGuessPackageName(Tcl_GetString(pathPtr), &linkCommandBuf);
 191     Tcl_DStringAppend (&linkCommandBuf, " -A ", -1);
 192     Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1);
 193     Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1);
 194     Tcl_DStringAppend (&linkCommandBuf, Tcl_GetString(pathPtr), -1);
 195     Tcl_DStringAppend (&linkCommandBuf, " ", -1);
 196
 197     if (FindLibraries (interp, pathPtr, &linkCommandBuf) != TCL_OK) {
 198         Tcl_DStringFree (&linkCommandBuf);
 199         return TCL_ERROR;
 200     }
 201
 202     linkCommand = Tcl_DStringValue (&linkCommandBuf);
 203
 204     /* Determine the starting address, and plug it into the command */
 205
 206     startAddress = (char *) (((unsigned long) sbrk (0)
 207                               + TCL_LOADSHIM + TCL_LOADALIGN - 1)
 208                              & (- TCL_LOADALIGN));
 209     p = strstr (linkCommand, "-T") + 3;
 210     sprintf (p, "%08lx", (long) startAddress);
 211     p [8] = ' ';
 212
 213     /* Run the linker */
 214
 215     status = Tcl_Eval (interp, linkCommand);
 216     Tcl_DStringFree (&linkCommandBuf);
 217     if (status != 0) {
 218         return TCL_ERROR;
 219     }
 220
 221     /* Open the linker's result file and read the header */
 222
 223     relocatedFd = open (relocatedFileName, O_RDONLY);
 224     if (relocatedFd < 0) {
 225         goto ioError;
 226     }
 227     status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead);
 228     if (status < sizeof relocatedHead) {
 229         goto ioError;
 230     }
 231
 232     /* Check the magic number */
 233
 234     if (relocatedHead.a_magic != OMAGIC) {
 235         Tcl_AppendResult (interp, "bad magic number in intermediate file \"",
 236                           relocatedFileName, "\"", (char *) NULL);
 237         goto failure;
 238     }
 239
 240     /* Make sure that memory allocation is still consistent */
 241
 242     if ((unsigned long) sbrk (0) > (unsigned long) startAddress) {
 243         Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.",
 244                        TCL_STATIC);
 245         goto failure;
 246     }
 247
 248     /* Make sure that the relocated module's size is reasonable */
 249
 250     relocatedSize = relocatedHead.a_text + relocatedHead.a_data
 251       + relocatedHead.a_bss;
 252     if (relocatedSize > TCL_LOADMAX) {
 253         Tcl_SetResult (interp, "module too big to load", TCL_STATIC);
 254         goto failure;
 255     }
 256
 257     /* Advance the break to protect the loaded module */
 258
 259     (void) brk (startAddress + relocatedSize);
 260
 261     /*
 262      * Seek to the start of the module's text.
 263      *
 264      * Note that this does not really work with large files (i.e. where
 265      * lseek64 exists and is different to lseek), but anyone trying to
 266      * dynamically load a binary that is larger than what can fit in
 267      * addressable memory is in trouble anyway...
 268      */
 269
 270 #if defined(__mips) || defined(mips)
 271     status = lseek (relocatedFd,
 272                     (off_t) N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o),
 273                     SEEK_SET);
 274 #else
 275     status = lseek (relocatedFd, (off_t) N_TXTOFF (relocatedHead), SEEK_SET);
 276 #endif
 277     if (status < 0) {
 278         goto ioError;
 279     }
 280
 281     /* Read in the module's text and data */
 282
 283     relocatedSize = relocatedHead.a_text + relocatedHead.a_data;
 284     if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) {
 285         brk (startAddress);
 286       ioError:
 287         Tcl_AppendResult (interp, "error on intermediate file \"",
 288                           relocatedFileName, "\": ", Tcl_PosixError (interp),
 289                           (char *) NULL);
 290       failure:
 291         (void) unlink (relocatedFileName);
 292         return TCL_ERROR;
 293     }
 294
 295     /* Close the intermediate file. */
 296
 297     (void) close (relocatedFd);
 298
 299     /* Arrange things so that intermediate symbol tables eventually get
 300     * deleted. */
 301
 302     if (SymbolTableFile != NULL) {
 303         UnlinkSymbolTable ();
 304     } else {
 305         atexit (UnlinkSymbolTable);
 306     }
 307     SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
 308     strcpy (SymbolTableFile, relocatedFileName);
 309
 310     *loadHandle = startAddress;
 311     return TCL_OK;
 312 }
 313 \f
 314 /*
 315  *----------------------------------------------------------------------
 316  *
 317  * TclpFindSymbol --
 318  *
 319  *      Looks up a symbol, by name, through a handle associated with
 320  *      a previously loaded piece of code (shared library).
 321  *
 322  * Results:
 323  *      Returns a pointer to the function associated with 'symbol' if
 324  *      it is found.  Otherwise returns NULL and may leave an error
 325  *      message in the interp's result.
 326  *
 327  *----------------------------------------------------------------------
 328  */
 329 Tcl_PackageInitProc*
 330 TclpFindSymbol(interp, loadHandle, symbol)
 331     Tcl_Interp *interp;
 332     Tcl_LoadHandle loadHandle;
 333     CONST char *symbol;
 334 {
 335     /* Look up the entry point in the load module's dictionary. */
 336     DictFn dictionary = (DictFn) loadHandle;
 337     return (Tcl_PackageInitProc*) dictionary(sym1);
 338 }
 339
 340 \f
 341 /*
 342  *------------------------------------------------------------------------
 343  *
 344  * FindLibraries --
 345  *
 346  *      Find the libraries needed to link a load module at run time.
 347  *
 348  * Results:
 349  *      A standard Tcl completion code.  If an error occurs,
 350  *      an error message is left in the interp's result.  The -l and -L
 351  *      flags are concatenated onto the dynamic string `buf'.
 352  *
 353  *------------------------------------------------------------------------
 354  */
 355
 356 static int
 357 FindLibraries (interp, pathPtr, buf)
 358     Tcl_Interp * interp;        /* Used for error reporting */
 359     Tcl_Obj * pathPtr;          /* Name of the load module */
 360     Tcl_DString * buf;          /* Buffer where the -l an -L flags */
 361 {
 362     FILE * f;                   /* The load module */
 363     int c = 0;                  /* Byte from the load module */
 364     char * p;
 365     CONST char *native;
 366
 367     char *fileName = Tcl_GetString(pathPtr);
 368
 369     /* Open the load module */
 370
 371     native = Tcl_FSGetNativePath(pathPtr);
 372     f = fopen(native, "rb");                            /* INTL: Native. */
 373
 374     if (f == NULL) {
 375         Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ",
 376                           Tcl_PosixError (interp), (char *) NULL);
 377         return TCL_ERROR;
 378     }
 379
 380     /* Search for the library list in the load module */
 381
 382     p = "@LIBS: ";
 383     while (*p != '\0' && (c = getc (f)) != EOF) {
 384         if (c == *p) {
 385             ++p;
 386         }
 387         else {
 388             p = "@LIBS: ";
 389             if (c == *p) {
 390                 ++p;
 391             }
 392         }
 393     }
 394
 395     /* No library list -- this must be an ill-formed module */
 396
 397     if (c == EOF) {
 398         Tcl_AppendResult (interp, "File \"", fileName,
 399                           "\" is not a Tcl load module.", (char *) NULL);
 400         (void) fclose (f);
 401         return TCL_ERROR;
 402     }
 403
 404     /* Accumulate the library list */
 405
 406     while ((c = getc (f)) != '\0' && c != EOF) {
 407         char cc = c;
 408         Tcl_DStringAppend (buf, &cc, 1);
 409     }
 410     (void) fclose (f);
 411
 412     if (c == EOF) {
 413         Tcl_AppendResult (interp, "Library directory in \"", fileName,
 414                           "\" ends prematurely.", (char *) NULL);
 415         return TCL_ERROR;
 416     }
 417
 418     return TCL_OK;
 419 }
 420 \f
 421 /*
 422  *------------------------------------------------------------------------
 423  *
 424  * UnlinkSymbolTable --
 425  *
 426  *      Remove the symbol table file from the last dynamic link.
 427  *
 428  * Results:
 429  *      None.
 430  *
 431  * Side effects:
 432  *      The symbol table file from the last dynamic link is removed.
 433  *      This function is called when (a) a new symbol table is present
 434  *      because another dynamic link is complete, or (b) the process
 435  *      is exiting.
 436  *------------------------------------------------------------------------
 437  */
 438
 439 static void
 440 UnlinkSymbolTable ()
 441 {
 442     (void) unlink (SymbolTableFile);
 443     ckfree (SymbolTableFile);
 444     SymbolTableFile = NULL;
 445 }
 446 \f
 447 /*
 448  *----------------------------------------------------------------------
 449  *
 450  * TclpUnloadFile --
 451  *
 452  *      Unloads a dynamically loaded binary code file from memory.
 453  *      Code pointers in the formerly loaded file are no longer valid
 454  *      after calling this function.
 455  *
 456  * Results:
 457  *      None.
 458  *
 459  * Side effects:
 460  *      Does nothing.  Can anything be done?
 461  *
 462  *----------------------------------------------------------------------
 463  */
 464
 465 void
 466 TclpUnloadFile(loadHandle)
 467     Tcl_LoadHandle loadHandle;  /* loadHandle returned by a previous call
 468                                  * to TclpDlopen().  The loadHandle is
 469                                  * a token that represents the loaded
 470                                  * file. */
 471 {
 472 }
 473 \f
 474 /*
 475  *----------------------------------------------------------------------
 476  *
 477  * TclGuessPackageName --
 478  *
 479  *      If the "load" command is invoked without providing a package
 480  *      name, this procedure is invoked to try to figure it out.
 481  *
 482  * Results:
 483  *      Always returns 0 to indicate that we couldn't figure out a
 484  *      package name;  generic code will then try to guess the package
 485  *      from the file name.  A return value of 1 would have meant that
 486  *      we figured out the package name and put it in bufPtr.
 487  *
 488  * Side effects:
 489  *      None.
 490  *
 491  *----------------------------------------------------------------------
 492  */
 493
 494 int
 495 TclGuessPackageName(fileName, bufPtr)
 496     CONST char *fileName;       /* Name of file containing package (already
 497                                  * translated to local form if needed). */
 498     Tcl_DString *bufPtr;        /* Initialized empty dstring.  Append
 499                                  * package name to this if possible. */
 500 {
 501     CONST char *p, *q;
 502     char *r;
 503
 504     if ((q = strrchr(fileName,'/'))) {
 505         q++;
 506     } else {
 507         q = fileName;
 508     }
 509     if (!strncmp(q,"lib",3)) {
 510         q+=3;
 511     }
 512     p = q;
 513     while ((*p) && (*p != '.') && ((*p<'0') || (*p>'9'))) {
 514         p++;
 515     }
 516     if ((p>q+2) && !strncmp(p-2,"_G0.",4)) {
 517         p-=2;
 518     }
 519     if (p<q) {
 520         return 0;
 521     }
 522
 523     Tcl_DStringAppend(bufPtr,q, p-q);
 524
 525     r = Tcl_DStringValue(bufPtr);
 526     r += strlen(r) - (p-q);
 527
 528     /*
 529      * Capitalize the string and then recompute the length.
 530      */
 531
 532     Tcl_UtfToTitle(r);
 533     Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
 534
 535     return 1;
 536 }