/* DEBUGGING TRANSFORMATIONS ************************************************ * Created by Steven Hammond: Argonne National Laboratory * * Last Updated April 11, 1991 * * * * debug:debug(): Performs both of the transformations specified below. The * * workspace remains unchanged by the operation. * * * * debug:deadcode(): checks for unreachable code, using the exports directive * * as a list of entrypoints. See DEAD.PTN for a transformation to remove the * * dead code. * * * * debug:singleton(): checks for singleton variables. The workspace remains * * unchanged by the operation. * * *****************************************************************************/ -exports("debug","deadcode","singleton","singcheck") -metacalls(debug, deadcode, singleton) /* Debug: call deadcode and singleton */ debug() { ; deadcode(), singleton() } /* Dead Code Detection */ -proc_metacalls(deadcode, coll:d_value, tests:is_program, coll:name) deadcode() { ; coll:collect(true(),coll:d_value("exports"),entrypoints), { ? entrypoints?=[] -> abort("No exports list"), default -> { ; tree:descendents(tests:named(entrypoints),condition), coll:collect(and(tests:is_program(),not(condition)),coll:name(),deads), print_deads(deads) } } } print_deads(deads) { ? deads ?= [{_,mod,name}|deads1] -> {|| co_coutil:error([mod,name, " is dead code"]), {? data(d) -> print_deads(deads1) } }, default -> skip() } /* Singleton Variable Detection */ singleton() { ; coll:collect(true(),debug:singcheck(),sings), print_singletons(sings) } singcheck(id,defn,r) { ? id ?= {_,_,name}, defn ?= program(args,decls,block) -> { ; proc_args(args,[],list1), proc_decls(decls,list1,list2), proc_body(block,list2,list3), singletons(id,list3,r) }, default -> {|| r=[] } } proc_name(name,list1,list2) { ? char(name) -> {|| list2=list1 }, name ?= {v,vname,_}, v=="_var" -> scan(vname,list1,list2) } proc_decls(vars,list1,list2) { ? vars ?= [{_,var}|vars1], var ?= {v,name,dim}, v=="_var" -> { ; scan(name,list1,list3), proc_dim(dim,list3,list4), proc_decls(vars1,list4,list2) }, vars ?= [] -> {|| list2=list1 } } proc_dim(dim,list1,list2) { ? dim ?= [dim1|dims], int(dim1) /*, dim1!=0 */ -> proc_dim(dims,list1,list2), dim ?= [dim1|dims], dim1 ?= {v,name,l}, v=="_var", l==[] -> { ; scan(name,list1,list3), proc_dim(dims,list3,list2) }, dim ?= [] -> {|| list2 = list1 } } proc_body(block,list1,list2) { ? block ?= block(type,body), body!=[] -> proc_block(body,list1,list2), block ?= {"->",guards,body} -> { ; proc_guards(guards,list1,list3), proc_body(body,list3,list2) }, block ?= call({_,_,name},args,annot) -> { ; proc_name(name,list1,list3), proc_args(args,list3,list4), proc_annot(annot,list4,list2) }, block ?= prim(op,args) -> { ; len(args,argcnt), prim_type(op,argcnt,type), { ? type == "infix", args?=[arg1,arg2] -> { ; proc_term(arg1,list1,list3), proc_term(arg2,list3,list2) }, type=="prefix" -> proc_args(args,list1,list2), default -> print(prim_error(op,args)) } }, default -> print(proc_body_error(block)) } len(l,s) { ? l ?= [_|l1] -> {|| s=r+1, len(l1,r)}, l ?= [] -> {|| s=0 } } prim_type(op,cnt,type) { ? op == "skip", cnt == 0 -> {|| type="prefix" }, op == "=", cnt == 2 -> {|| type="infix" }, op == ":=", cnt == 2 -> {|| type="infix" }, op == "make_tuple", cnt == 2 -> {|| type="prefix" }, op == "append_stream", cnt == 3 -> {|| type="prefix" }, op == "print", cnt == 1 -> {|| type="prefix" }, op == "exit", cnt == 1 -> {|| type="prefix" }, op == "send", cnt == 3 -> {|| type="prefix" }, op == "arity", cnt == 2 -> {|| type="prefix" }, default -> {|| type = "prefix", co_coutil:error(["Warning - unknown primitive: ",op,cnt]) } } proc_block(rules,list1,list2) { ? rules ?= [rule|rules1] -> { ; proc_body(rule,list1,list3), proc_block(rules1,list3,list2) }, rules ?=[] -> {|| list2 = list1 }, default -> print(proc_block_error(rules)) } proc_args(args,list1,list2) { ? args ?= [param|args1] -> { ; proc_term(param,list1,list3), proc_args(args1,list3,list2) }, args ?= [] -> {|| list2 = list1 } } proc_annot(annot,list1,list2) { ? annot ?= [] -> {|| list2 = list1 }, char(annot) -> {|| list2 = list1 }, int(annot) -> {|| list2 = list1 }, annot ?= {v,n,ds}, ds==[], v=="_var" -> scan(n,list1,list2), default -> print(bad_annotation(annot)) } proc_guards(guards,list1,list2) { ? guards ?= [guard|guards1] -> { ? guard ?= {_,arg1,arg2} -> { ; proc_term(arg1,list1,list3), proc_term(arg2,list3,list4), proc_guards(guards1,list4,list2) }, guard ?= {_,arg} -> { ; proc_term(arg,list1,list3), proc_guards(guards1,list3,list2) } }, guards == "default" -> {|| list2 = list1 }, guards ?= [] -> {|| list2 = list1 } } proc_term(term,list1,list2) { ? char(term) -> {|| list2 = list1 }, int(term) -> {|| list2 = list1 }, double(term) -> {|| list2 = list1 }, term ?= [] -> {|| list2 = list1 }, term ?= {v,n,_}, v == "_var" -> scan(n,list1,list2), term ?= {v,{op,a1,a2}}, v == "_exp" -> proc_exp(a1,a2,list1,list2), default -> proc_tup(term,0,sizeof(term),list1,list2) } proc_exp(a1,a2,list1,list2) { ; proc_term(a1,list1,list3), proc_term(a2,list3,list2) } proc_tup(as,st,sz,list1,list2) { ? st { ; proc_term(as[st],list1,list3), proc_tup(as,st+1,sz,list3,list2) }, st==sz -> {|| list2 = list1 } } scan(key,list1,list2) { ? key != "_" -> { ? list1 ?= [i|list3], i ?= {item,n} -> { ? key == item -> { ; n1 = n+1, list2 = [{item,n1}|list3] }, default -> { ; scan(key,list3,list4), list2 = [i|list4] } }, list1 ?= [] -> {|| list2 = [{key,1}] } }, key == "_" -> {|| list2 = list1 /* don't care condition */ } } singletons(id,list,r) { ? list ?= [{item,n}|list1] -> { ? n==1 -> {|| r=[sing(id,item)|r1], singletons(id,list1,r1)}, default -> singletons(id,list1,r) }, list ?= [] -> {|| r=[] } } print_singletons(list) { ? list?=[{_,{_,mod,name},var}|list1] -> {|| stdio:printf("%s:%s - Signleton variable %s\n",{mod,name,var},d), {? data(d) -> print_singletons(list1) } }, default -> skip() }