source: release/1.9/source/lisp-kernel/albt.c @ 16083

Last change on this file since 16083 was 15473, checked in by gb, 7 years ago

Ensure that darwin_sigreturn() is prototyped on platforms where it's
used.

Remove some remaining Mach-isms (notably the paging info stuff used
by GC-VERBOSE; just use getrusage()).

Make sure that the right headers are included in threads.h, to support
the remaining Mach-ism (use of Mach semaphores. Apple still doesn't
implement POSIX semaphores, though the functions have been prototyped
for several years now.)

This builds without warnings or errors on 10.8.1 with Xcode 4.4's
toolchain. It -may- address the problems described in ticket:1019.

File size: 4.1 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#include "lispdcmd.h"
19#ifdef LINUX
20#define __USE_GNU 1
21#endif
22
23#ifndef WINDOWS
24#include <dlfcn.h>
25#endif
26
27
28extern Boolean lisp_frame_p(lisp_frame *);
29
30void
31print_lisp_frame(lisp_frame *frame)
32{
33  LispObj fun = frame->savefn, rpc = frame->savelr;
34  int delta = 0;
35  Dl_info info;
36  char *spname;
37
38  if ((fun == 0) || (fun == fulltag_misc)) {
39    spname = "unknown ?";
40#ifndef STATIC
41    if (dladdr((void *)ptr_from_lispobj(rpc), &info)) {
42      spname = (char *)(info.dli_sname);
43#ifdef DARWIN
44      if (spname[-1] != '_') {
45        --spname;
46      }
47#endif
48    }
49#endif
50    Dprintf("(#x%08X) #x%08X : (subprimitive %s)", frame, rpc, spname);
51  } else {
52    if ((fulltag_of(fun) != fulltag_misc) ||
53        (header_subtag(header_of(fun)) != subtag_function)) {
54      Dprintf("(#x%08X) #x%08X : (not a function!)", frame, rpc);
55    } else {
56      LispObj code_vector = deref(fun, 2);
57     
58      if ((rpc >= (code_vector+misc_data_offset)) &&
59          (rpc < ((code_vector+misc_data_offset)+(header_element_count(header_of(code_vector))<<2)))) {
60        delta = (rpc - (code_vector+misc_data_offset));
61      }
62      Dprintf("(#x%08X) #x%08X : %s + %d", frame, rpc, print_lisp_object(fun), delta);
63    }
64  }
65}
66
67
68
69
70/* Walk frames from "start" to "end".
71   Say whatever can be said about foreign frames and lisp frames.
72*/
73
74void
75walk_stack_frames(lisp_frame *start, lisp_frame *end) 
76{
77  lisp_frame *next;
78  Dprintf("\n");
79  while (start < end) {
80
81    if (lisp_frame_p(start)) {
82      print_lisp_frame(start);
83      next = start + 1;     
84    } else {
85      LispObj *current = (LispObj *)start,
86        header = *current;
87      int tag = fulltag_of(header);
88      natural elements;
89
90      if (immheader_tag_p(tag)) {
91        next = (lisp_frame *)skip_over_ivector((natural)current, header);
92      } else if (nodeheader_tag_p(tag)) {
93        elements = (header_element_count(header)+2)&~1;
94        next = (lisp_frame *)(current+elements);
95      } else if (header == stack_alloc_marker) {
96        next = (lisp_frame *)(current[1]);
97      } else {
98        fprintf(dbgout, "Bad frame! (0x%x)\n", start);
99        next = end;
100      }
101    }
102    start = next;
103  }
104}
105
106char *
107interrupt_level_description(TCR *tcr)
108{
109  signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr);
110  if (level < 0) {
111    if (tcr->interrupt_pending) {
112      return "disabled(pending)";
113    } else {
114      return "disabled";
115    }
116  } else {
117    return "enabled";
118  }
119}
120
121void
122walk_other_areas()
123{
124  TCR *start = (TCR *)get_tcr(true), *tcr = start->next;
125  area *a;
126  char *ilevel = interrupt_level_description(tcr);
127
128  while (tcr != start) {
129    a = tcr->cs_area;
130    Dprintf("\n\n TCR = 0x%lx, cstack area #x%lx,  native thread ID = 0x%lx, interrupts %s", tcr, a,  tcr->native_thread_id, ilevel);
131    walk_stack_frames((lisp_frame *) (a->active), (lisp_frame *) (a->high));
132    tcr = tcr->next;
133  }
134}
135
136void
137plbt_sp(LispObj currentSP)
138{
139  area *cs_area;
140 
141{
142    TCR *tcr = (TCR *)get_tcr(true);
143    char *ilevel = interrupt_level_description(tcr);
144    cs_area = tcr->cs_area;
145    if ((((LispObj) ptr_to_lispobj(cs_area->low)) > currentSP) ||
146        (((LispObj) ptr_to_lispobj(cs_area->high)) < currentSP)) {
147      Dprintf("\nStack pointer [#x%lX] in unknown area.", currentSP);
148    } else {
149      fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel);
150      walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentSP), (lisp_frame *) (cs_area->high));
151      walk_other_areas();
152    }
153  } 
154}
155
156 
157void
158plbt(ExceptionInformation *xp)
159{
160  plbt_sp(xpGPR(xp, Rsp));
161}
162   
Note: See TracBrowser for help on using the repository browser.