ghc-dup: 55261fcc8c4a43f642c1d1a9abaafde3009ff666
1: #include "Cmm.h"
2:
3:
4: dupClosure ( W_ n )
5: {
6: /* args: R1 = closure to analyze */
7:
8: W_ clos;
9: clos = UNTAG(n);
10:
11: // W_ info;
12: // info = %GET_STD_INFO(clos);
13:
14: W_ ha;
15: (ha) = ccall 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: return (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: ccall dupUnsupportedWarning(clos "ptr");
50: return (clos);
51:
52: type_ok:
53: W_ len;
54: (len) = ccall 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: return (copy);
74: } else {
75: ccall dupStaticWarning(clos "ptr");
76: return (clos);
77: }
78: }
79:
80: deepDupClosure ( W_ n )
81: {
82: /* args: R1 = closure to analyze */
83:
84: W_ clos;
85: clos = UNTAG(n);
86:
87:
88: W_ info;
89: info = %GET_STD_INFO(clos);
90:
91: W_ ha;
92: (ha) = ccall 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: return (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: ccall dupUnsupportedWarning(clos "ptr");
127: return (clos);
128:
129: type_ok:
130: W_ len;
131: (len) = ccall 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: //ccall 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) == ghcduzuCURRENT_PACKAGE_KEY_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) = ghcduzuCURRENT_PACKAGE_KEY_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: //ccall printObj(copy "ptr");
248: return (copy);
249: } else {
250: ccall dupStaticWarning(clos "ptr");
251: return (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: }*/
Generated by git2html.