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.