Author: chriswarbo <chriswarbo@gmail.com>
Date: Fri Feb 3 01:42:20 PM UTC 2017
Parent: 775a7bb00f9e28e12f3222241ad4b66d8abe3fb2
Log message:
GHC bump
1: diff --git a/cbits/dup-prim.cmm b/cbits/dup-prim.cmm
2: index 4f82734..55261fc 100644
3: --- a/cbits/dup-prim.cmm
4: +++ b/cbits/dup-prim.cmm
5: @@ -1,18 +1,18 @@
6: #include "Cmm.h"
7:
8:
9: -dupClosure
10: +dupClosure ( W_ n )
11: {
12: /* args: R1 = closure to analyze */
13:
14: W_ clos;
15: - clos = UNTAG(R1);
16: + clos = UNTAG(n);
17:
18: // W_ info;
19: // info = %GET_STD_INFO(clos);
20:
21: W_ ha;
22: - (ha) = foreign "C" dupHeapAlloced(clos "ptr") [];
23: + (ha) = ccall dupHeapAlloced(clos "ptr");
24:
25: if (ha > 0) {
26: W_ type;
27: @@ -28,7 +28,7 @@ dupClosure
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: + return (clos);
33: } else {
34: goto type_ok;
35: }
36: @@ -46,17 +46,17 @@ dupClosure
37: }
38:
39: type_not_ok:
40: - foreign "C" dupUnsupportedWarning(clos "ptr") [];
41: - RET_P(clos);
42: + ccall dupUnsupportedWarning(clos "ptr");
43: + return (clos);
44:
45: type_ok:
46: W_ len;
47: - (len) = foreign "C" dupClosureSize(clos "ptr") [];
48: + (len) = ccall dupClosureSize(clos "ptr");
49:
50: W_ bytes;
51: bytes = WDS(len);
52:
53: - ALLOC_PRIM (bytes, R1_PTR, dupClosure);
54: + ALLOC_PRIM (bytes/*, R1_PTR, dupClosure*/);
55:
56: W_ copy;
57: copy = Hp - bytes + WDS(1);
58: @@ -70,26 +70,26 @@ dupClosure
59: goto for;
60: }
61:
62: - RET_P(copy);
63: + return (copy);
64: } else {
65: - foreign "C" dupStaticWarning(clos "ptr") [];
66: - RET_P(clos);
67: + ccall dupStaticWarning(clos "ptr");
68: + return (clos);
69: }
70: }
71:
72: -deepDupClosure
73: +deepDupClosure ( W_ n )
74: {
75: /* args: R1 = closure to analyze */
76:
77: W_ clos;
78: - clos = UNTAG(R1);
79: + clos = UNTAG(n);
80:
81:
82: W_ info;
83: info = %GET_STD_INFO(clos);
84:
85: W_ ha;
86: - (ha) = foreign "C" dupHeapAlloced(clos "ptr") [];
87: + (ha) = ccall dupHeapAlloced(clos "ptr");
88:
89: if (ha > 0) {
90: W_ type;
91: @@ -105,7 +105,7 @@ deepDupClosure
92: case CONSTR, CONSTR_1_0, CONSTR_0_1, CONSTR_1_1,
93: CONSTR_2_0, CONSTR_0_2, CONSTR_STATIC, CONSTR_NOCAF_STATIC: {
94: if (TO_W_(%INFO_PTRS(%GET_STD_INFO(clos))) > 0) {
95: - RET_P(clos);
96: + return (clos);
97: } else {
98: goto type_ok;
99: }
100: @@ -123,12 +123,12 @@ deepDupClosure
101: }
102:
103: type_not_ok:
104: - foreign "C" dupUnsupportedWarning(clos "ptr") [];
105: - RET_P(clos);
106: + ccall dupUnsupportedWarning(clos "ptr");
107: + return (clos);
108:
109: type_ok:
110: W_ len;
111: - (len) = foreign "C" dupClosureSize(clos "ptr") [];
112: + (len) = ccall dupClosureSize(clos "ptr");
113:
114: W_ ptrs;
115: ptrs = TO_W_(%INFO_PTRS(info));
116: @@ -138,8 +138,8 @@ deepDupClosure
117: // thunk consisting of a header and the pointer
118: bytes = WDS(len) + ptrs * SIZEOF_StgAP + WDS (ptrs);
119:
120: - ALLOC_PRIM (bytes, R1_PTR, dupClosure);
121: - //foreign "C" printObj(clos "ptr") [];
122: + ALLOC_PRIM (bytes/*, R1_PTR, dupClosure*/);
123: + //ccall printObj(clos "ptr");
124:
125: W_ copy;
126: copy = Hp - WDS(len) + WDS(1);
127: @@ -156,7 +156,7 @@ deepDupClosure
128: // We need to short-ciruit deepDup calls here
129: if (StgHeader_info(copy) == stg_ap_2_upd_info
130: &&
131: - StgThunk_payload(copy,0) == ghczmdupzm0zi1_GHCziDup_deepDupFun_closure) {
132: + StgThunk_payload(copy,0) == ghcduzuCURRENT_PACKAGE_KEY_GHCziDup_deepDupFun_closure) {
133: goto done;
134: }
135:
136: @@ -190,7 +190,7 @@ deepDupClosure
137: //StgAP_fun(ap) = Dup_deepDupFun_closure;
138:
139: SET_HDR(ap, stg_ap_2_upd_info, CCCS);
140: - StgThunk_payload(ap,0) = ghczmdupzm0zi1_GHCziDup_deepDupFun_closure;
141: + StgThunk_payload(ap,0) = ghcduzuCURRENT_PACKAGE_KEY_GHCziDup_deepDupFun_closure;
142:
143: // SET_HDR(ap, stg_deepDup_info, CCCS);
144:
145: @@ -244,17 +244,17 @@ deepDupClosure
146: }
147:
148: done:
149: - //foreign "C" printObj(copy "ptr") [];
150: - RET_P(copy);
151: + //ccall printObj(copy "ptr");
152: + return (copy);
153: } else {
154: - foreign "C" dupStaticWarning(clos "ptr") [];
155: - RET_P(clos);
156: + ccall dupStaticWarning(clos "ptr");
157: + return (clos);
158: }
159: }
160:
161: // inspired by rts/StgStdThunks.cmm
162: // But does not work yet.
163: -INFO_TABLE(stg_deepDup,1,0,THUNK_1_0,"stg_deepDup_info","stg_deepDup_info")
164: +/*INFO_TABLE(stg_deepDup,1,0,THUNK_1_0,"stg_deepDup_info","stg_deepDup_info")
165: {
166: TICK_ENT_DYN_THK();
167: STK_CHK_NP(SIZEOF_StgUpdateFrame+WDS(1));
168: @@ -266,5 +266,4 @@ INFO_TABLE(stg_deepDup,1,0,THUNK_1_0,"stg_deepDup_info","stg_deepDup_info")
169: Sp_adj(-1); // for stg_ap_*_ret
170: R1 = StgThunk_payload(R1,0);
171: jump deepDupClosure;
172: -}
173: -
174: +}*/
175: diff --git a/ghc-dup.cabal b/ghc-dup.cabal
176: index 209ac9a..d0656c2 100644
177: --- a/ghc-dup.cabal
178: +++ b/ghc-dup.cabal
179: @@ -1,5 +1,5 @@
180: Name: ghc-dup
181: -Version: 0.1
182: +Version: 0.2
183: Synopsis: Explicitly prevent sharing
184: Description:
185: This package provides two new operations, 'GHC.Dup.dup' and 'GHC.Dup.deepDup', that allow the
186: @@ -30,11 +30,12 @@ Library
187: Exposed-modules: GHC.Dup
188: Default-Language: Haskell2010
189: Build-depends:
190: - base == 4.5.* || == 4.6.*,
191: + base == 4.8.* || == 4.9.*,
192: ghc
193: C-Sources: cbits/dup.c cbits/dup-prim.cmm
194: Hs-source-dirs: src/
195: Ghc-options: -Wall
196: + default-extensions: CPP
197:
198: -- if flag(prim-supports-any)
199: -- cpp-options: -DPRIM_SUPPORTS_ANY