Apply same logic about copyable closures when creating thunkgs in deepDup
[darcs-mirror-ghc-dup.git] / cbits / dup-prim.cmm
1 #include "Cmm.h"
2
3
4 dupClosure
5 {
6 /* args: R1 = closure to analyze */
7
8     W_ clos;
9     clos = UNTAG(R1);
10
11 //    W_ info;
12 //    info = %GET_STD_INFO(clos);
13
14     W_ ha;
15     (ha) = foreign "C" dupHeapAlloced(clos "ptr") [];
16
17     if (ha > 0) {
18         W_ type;
19         type = TO_W_(%INFO_TYPE(%GET_STD_INFO(clos)));
20         switch [0 .. N_CLOSURE_TYPES] type {
21             case FUN, FUN_1_0, FUN_0_1, FUN_1_1,
22                  FUN_2_0, FUN_0_2, FUN_STATIC: {
23                  goto type_ok;
24
25             }
26             // Do not copy data without pointers
27             // (includes static data such as [])
28             case CONSTR, CONSTR_1_0, CONSTR_0_1, CONSTR_1_1,
29                  CONSTR_2_0, CONSTR_0_2, CONSTR_STATIC, CONSTR_NOCAF_STATIC: {
30                 if (TO_W_(%INFO_PTRS(%GET_STD_INFO(clos))) > 0) {
31                      RET_P(clos);
32                 } else {
33                      goto type_ok;
34                 }
35             }
36
37             // Thunks are good
38             case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, THUNK_0_2,
39                  THUNK_STATIC, THUNK_SELECTOR, AP: {
40                 goto type_ok;
41             }
42
43             default: {
44                 goto type_not_ok;
45             }
46         }
47
48     type_not_ok:
49         foreign "C" dupUnsupportedWarning(clos "ptr") [];
50         RET_P(clos);
51
52     type_ok:
53         W_ len;
54         (len) = foreign "C" dupClosureSize(clos "ptr") [];
55
56         W_ bytes;
57         bytes = WDS(len);
58
59         ALLOC_PRIM (bytes, R1_PTR, dupClosure);
60
61         W_ copy;
62         copy = Hp - bytes + WDS(1);
63
64         W_ p;
65         p = 0;
66     for:
67         if(p < len) {
68              W_[copy + WDS(p)] = W_[clos + WDS(p)];
69              p = p + 1;
70              goto for;
71         }
72
73         RET_P(copy);
74     } else {
75         foreign "C" dupStaticWarning(clos "ptr") [];
76         RET_P(clos);
77     }
78 }
79
80 deepDupClosure
81 {
82 /* args: R1 = closure to analyze */
83
84     W_ clos;
85     clos = UNTAG(R1);
86
87
88     W_ info;
89     info = %GET_STD_INFO(clos);
90
91     W_ ha;
92     (ha) = foreign "C" dupHeapAlloced(clos "ptr") [];
93
94     if (ha > 0) {
95         W_ type;
96         type = TO_W_(%INFO_TYPE(%GET_STD_INFO(clos)));
97         switch [0 .. N_CLOSURE_TYPES] type {
98             case FUN, FUN_1_0, FUN_0_1, FUN_1_1,
99                  FUN_2_0, FUN_0_2, FUN_STATIC: {
100                  goto type_ok;
101
102             }
103             // Do not copy data without pointers
104             // (includes static data such as [])
105             case CONSTR, CONSTR_1_0, CONSTR_0_1, CONSTR_1_1,
106                  CONSTR_2_0, CONSTR_0_2, CONSTR_STATIC, CONSTR_NOCAF_STATIC: {
107                 if (TO_W_(%INFO_PTRS(%GET_STD_INFO(clos))) > 0) {
108                      RET_P(clos);
109                 } else {
110                      goto type_ok;
111                 }
112             }
113
114             // Thunks are good
115             case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, THUNK_0_2,
116                  THUNK_STATIC, THUNK_SELECTOR, AP: {
117                 goto type_ok;
118             }
119
120             default: {
121                 goto type_not_ok;
122             }
123         }
124
125     type_not_ok:
126         foreign "C" dupUnsupportedWarning(clos "ptr") [];
127         RET_P(clos);
128
129     type_ok:
130         W_ len;
131         (len) = foreign "C" dupClosureSize(clos "ptr") [];
132
133         W_ ptrs;
134         ptrs  = TO_W_(%INFO_PTRS(info));
135
136         W_ bytes;
137         // We need to copy the closure, plus for every pointer therein, make a
138         // thunk consisting of a header and the pointer
139         bytes = WDS(len) + ptrs * SIZEOF_StgAP + WDS (ptrs);
140
141         ALLOC_PRIM (bytes, R1_PTR, dupClosure);
142         //foreign "C" printObj(clos "ptr") [];
143
144         W_ copy;
145         copy = Hp - WDS(len) + WDS(1);
146
147         W_ p;
148         p = 0;
149     for1:
150         if(p < len) {
151              W_[copy + WDS(p)] = W_[clos + WDS(p)];
152              p = p + 1;
153              goto for1;
154         }
155
156         // We need to short-ciruit deepDup calls here
157         if (StgHeader_info(copy) == stg_ap_2_upd_info
158             &&
159             StgThunk_payload(copy,0) == ghczmdupzm0zi1_GHCziDup_deepDupFun_closure) {
160             goto done;
161         }
162
163         
164         W_ thunks;
165         thunks = Hp - bytes + WDS(1);
166
167         W_ payloadOffset;
168         payloadOffset = 0;
169
170         W_ type;
171         type = TO_W_(%INFO_TYPE(info));
172         switch [0 .. N_CLOSURE_TYPES] type {
173             case THUNK, THUNK_1_0, THUNK_0_1, THUNK_1_1,
174                  THUNK_2_0, THUNK_0_2, THUNK_STATIC: {
175                 payloadOffset = 1;
176                 goto out;
177             }
178             default: {
179                 goto out;
180             }
181         }
182     out:
183
184         p = 0;
185     for2:
186         if(p < ptrs) {
187             W_ ap;
188             ap = thunks + p * SIZEOF_StgAP + WDS(p);
189             //StgAP_n_args(ap) = HALF_W_(1);
190             //StgAP_fun(ap) = Dup_deepDupFun_closure;
191
192             SET_HDR(ap, stg_ap_2_upd_info, CCCS);
193             StgThunk_payload(ap,0) = ghczmdupzm0zi1_GHCziDup_deepDupFun_closure;
194
195             // SET_HDR(ap, stg_deepDup_info, CCCS);
196
197             W_ clos2;
198             clos2 = UNTAG(StgClosure_payload(clos, p + payloadOffset));
199             // StgAP_payload(ap, 0) = clos2;
200             StgThunk_payload(ap,1) = clos2;
201             //StgThunk_payload(ap,0) = clos2;
202
203             type = TO_W_(%INFO_TYPE(%GET_STD_INFO(clos2)));
204             switch [0 .. N_CLOSURE_TYPES] type {
205                 // A fun must stay a fun closure
206                 // What about pointers therein? Do we need to recurse here?
207                 case FUN, FUN_1_0, FUN_0_1, FUN_1_1,
208                      FUN_2_0, FUN_0_2, FUN_STATIC: {
209                     goto out2;
210                 }
211                 // Do not copy data without pointers
212                 // (includes static data such as [])
213                 case CONSTR, CONSTR_1_0, CONSTR_0_1, CONSTR_1_1,
214                      CONSTR_2_0, CONSTR_0_2, CONSTR_STATIC, CONSTR_NOCAF_STATIC: {
215                     if (TO_W_(%INFO_PTRS(%GET_STD_INFO(clos2))) > 0) {
216                         StgClosure_payload(copy, p + payloadOffset) = ap;
217                     }
218                     goto out2;
219                 }
220                 // We can short-cut indirections here, just for the fun of it
221                 /*
222                 case IND, IND_PERM, IND_STATIC, BLACKHOLE: {
223                     StgThunk_payload(ap,1) = StgInd_indirectee(clos2);
224                     StgClosure_payload(copy, p + payloadOffset) = ap;
225                     goto out2;
226                 }
227                 */
228
229                 // Thunks are good
230                 case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, THUNK_0_2,
231                      THUNK_STATIC, THUNK_SELECTOR, AP: {
232                     StgClosure_payload(copy, p + payloadOffset) = ap;
233                     goto out2;
234                 }
235
236                 default: {
237                     goto out2;
238                 }
239             }
240         out2:
241
242             p = p + 1;
243             goto for2;
244         }
245
246         done:
247         //foreign "C" printObj(copy "ptr") [];
248         RET_P(copy);
249     } else {
250         foreign "C" dupStaticWarning(clos "ptr") [];
251         RET_P(clos);
252     }
253 }
254
255 // inspired by rts/StgStdThunks.cmm 
256 // But does not work yet.
257 INFO_TABLE(stg_deepDup,1,0,THUNK_1_0,"stg_deepDup_info","stg_deepDup_info")
258 {
259   TICK_ENT_DYN_THK();
260   STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(1));
261   UPD_BH_UPDATABLE();
262   LDV_ENTER(R1);
263   ENTER_CCS_THUNK(R1);
264   PUSH_UPD_FRAME(Sp-SIZEOF_StgUpdateFrame,R1);
265   Sp = Sp - SIZEOF_StgUpdateFrame;
266   Sp_adj(-1); // for stg_ap_*_ret
267   R1 = StgThunk_payload(R1,0);
268   jump deepDupClosure;
269 }
270