update submodules for GHC.HetMet.GArrow -> Control.GArrow renaming
[ghc-hetmet.git] / rts / Weak.c
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 1998-1999
4  *
5  * Weak pointers / finalizers
6  *
7  * ---------------------------------------------------------------------------*/
8
9 #include "PosixSource.h"
10 #include "Rts.h"
11 #include "RtsAPI.h"
12
13 #include "RtsUtils.h"
14 #include "Weak.h"
15 #include "Schedule.h"
16 #include "Prelude.h"
17 #include "Trace.h"
18
19 // ForeignPtrs with C finalizers rely on weak pointers inside weak_ptr_list
20 // to always be in the same order.
21
22 StgWeak *weak_ptr_list;
23
24 void
25 runCFinalizer(void *fn, void *ptr, void *env, StgWord flag)
26 {
27     if (flag)
28         ((void (*)(void *, void *))fn)(env, ptr);
29     else
30         ((void (*)(void *))fn)(ptr);
31 }
32
33 void
34 runAllCFinalizers(StgWeak *list)
35 {
36     StgWeak *w;
37     Task *task;
38
39     task = myTask();
40     if (task != NULL) {
41         task->running_finalizers = rtsTrue;
42     }
43
44     for (w = list; w; w = w->link) {
45         StgArrWords *farr;
46
47         farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer);
48
49         if ((StgClosure *)farr != &stg_NO_FINALIZER_closure)
50             runCFinalizer((void *)farr->payload[0],
51                           (void *)farr->payload[1],
52                           (void *)farr->payload[2],
53                           farr->payload[3]);
54     }
55
56     if (task != NULL) {
57         task->running_finalizers = rtsFalse;
58     }
59 }
60
61 /*
62  * scheduleFinalizers() is called on the list of weak pointers found
63  * to be dead after a garbage collection.  It overwrites each object
64  * with DEAD_WEAK, and creates a new thread to run the pending finalizers.
65  *
66  * This function is called just after GC.  The weak pointers on the
67  * argument list are those whose keys were found to be not reachable,
68  * however the value and finalizer fields have by now been marked live.
69  * The weak pointer object itself may not be alive - i.e. we may be
70  * looking at either an object in from-space or one in to-space.  It
71  * doesn't really matter either way.
72  *
73  * Pre-condition: sched_mutex _not_ held.
74  */
75
76 void
77 scheduleFinalizers(Capability *cap, StgWeak *list)
78 {
79     StgWeak *w;
80     StgTSO *t;
81     StgMutArrPtrs *arr;
82     StgWord size;
83     nat n, i;
84     Task *task;
85
86     task = myTask();
87     if (task != NULL) {
88         task->running_finalizers = rtsTrue;
89     }
90
91     // count number of finalizers, and kill all the weak pointers first...
92     n = 0;
93     for (w = list; w; w = w->link) { 
94         StgArrWords *farr;
95
96         // Better not be a DEAD_WEAK at this stage; the garbage
97         // collector removes DEAD_WEAKs from the weak pointer list.
98         ASSERT(w->header.info != &stg_DEAD_WEAK_info);
99
100         if (w->finalizer != &stg_NO_FINALIZER_closure) {
101             n++;
102         }
103
104         farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer);
105
106         if ((StgClosure *)farr != &stg_NO_FINALIZER_closure)
107             runCFinalizer((void *)farr->payload[0],
108                           (void *)farr->payload[1],
109                           (void *)farr->payload[2],
110                           farr->payload[3]);
111
112 #ifdef PROFILING
113         // A weak pointer is inherently used, so we do not need to call
114         // LDV_recordDead().
115         //
116         // Furthermore, when PROFILING is turned on, dead weak
117         // pointers are exactly as large as weak pointers, so there is
118         // no need to fill the slop, either.  See stg_DEAD_WEAK_info
119         // in StgMiscClosures.hc.
120 #endif
121         SET_HDR(w, &stg_DEAD_WEAK_info, w->header.prof.ccs);
122     }
123         
124     if (task != NULL) {
125         task->running_finalizers = rtsFalse;
126     }
127
128     // No finalizers to run?
129     if (n == 0) return;
130
131     debugTrace(DEBUG_weak, "weak: batching %d finalizers", n);
132
133     size = n + mutArrPtrsCardTableSize(n);
134     arr = (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
135     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
136     SET_HDR(arr, &stg_MUT_ARR_PTRS_FROZEN_info, CCS_SYSTEM);
137     arr->ptrs = n;
138     arr->size = size;
139
140     n = 0;
141     for (w = list; w; w = w->link) {
142         if (w->finalizer != &stg_NO_FINALIZER_closure) {
143             arr->payload[n] = w->finalizer;
144             n++;
145         }
146     }
147     // set all the cards to 1
148     for (i = n; i < size; i++) {
149         arr->payload[i] = (StgClosure *)(W_)(-1);
150     }
151
152     t = createIOThread(cap, 
153                        RtsFlags.GcFlags.initialStkSize, 
154                        rts_apply(cap,
155                            rts_apply(cap,
156                                (StgClosure *)runFinalizerBatch_closure,
157                                rts_mkInt(cap,n)), 
158                            (StgClosure *)arr)
159         );
160     scheduleThread(cap,t);
161 }