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