SCM Repository
View of /sml/branches/SMLNJ/src/MLRISC/IR/mlrisc-cfg-gen.sml
Parent Directory
|
Revision Log
Revision 469 -
(download)
(annotate)
Wed Nov 10 22:42:52 1999 UTC (21 years, 5 months ago) by monnier
File size: 6977 byte(s)
Wed Nov 10 22:42:52 1999 UTC (21 years, 5 months ago) by monnier
File size: 6977 byte(s)
version 110.23
(* * This module takes a stream of instructions and build a CFG. * The building can be incremental. * * -- Allen *) functor ControlFlowGraphGenFn (structure CFG : CONTROL_FLOW_GRAPH structure Stream : INSTRUCTION_STREAM structure InsnProps : INSN_PROPERTIES sharing CFG.I = InsnProps.I sharing CFG.P = Stream.P ) : CONTROL_FLOW_GRAPH_GEN = struct structure CFG = CFG structure I = CFG.I structure P = CFG.P structure G = Graph structure W = CFG.W structure S = Stream fun error msg = MLRiscErrorMsg.error("ControlFlowGraphGen",msg) fun builder(CFG) = let val NOBLOCK = CFG.newBlock(~1,ref 0) val currentBlock = ref NOBLOCK val newBlocks = ref [] : CFG.block list ref val entryLabels = ref [] : Label.label list ref fun can'tUse _ = error "unimplemented" exception NotFound val labelMap = Intmap.new(32,NotFound) val newLabel = Intmap.add labelMap val CFG = ref CFG val aliasF = ref can'tUse : (int * int -> unit) ref fun init _ = (currentBlock := NOBLOCK; newBlocks := []; entryLabels := []; Intmap.clear labelMap; aliasF := can'tUse ) val _ = init() fun next cfg = CFG := cfg fun newBlock() = let val G.GRAPH cfg = !CFG val id = #new_id cfg () val b = CFG.newBlock(id,ref 0) in currentBlock := b; newBlocks := b :: !newBlocks; #add_node cfg (id,b); b end fun getBlock() = case !currentBlock of CFG.BLOCK{id= ~1,...} => newBlock() | b => b fun newPseudoOpBlock() = (case !currentBlock of CFG.BLOCK{id= ~1,...} => newBlock() | b as CFG.BLOCK{insns=ref [],...} => b | _ => newBlock() ) fun insertOp p = let val CFG.BLOCK{data,...} = newPseudoOpBlock() in data := !data @ [p] end fun defineLabel(l as Label.Label{id=labelId,...}) = let val CFG.BLOCK{id,labels,...} = newPseudoOpBlock() in labels := l :: !labels; newLabel(labelId,id) end fun entryLabel l = (defineLabel l; entryLabels := l :: !entryLabels) fun pseudoOp p = insertOp(CFG.PSEUDO p) fun annotation a = let val CFG.BLOCK{annotations,...} = getBlock() in annotations := a :: !annotations end fun exitBlock liveOut = let fun setLiveOut(CFG.BLOCK{annotations,...}) = annotations := #create CFG.LIVEOUT liveOut :: !annotations in case !currentBlock of CFG.BLOCK{id= ~1,...} => (case !newBlocks of [] => error "exitBlock" | b::_ => setLiveOut b ) | b => setLiveOut b end fun comment msg = annotation(#create BasicAnnotations.COMMENT msg) fun emitInstr i = let val CFG.BLOCK{insns,...} = getBlock() in insns := i :: !insns; if InsnProps.instrKind i = InsnProps.IK_JUMP then currentBlock := NOBLOCK else () end fun finish(annotations) = let val G.GRAPH cfg = !CFG val _ = CFG.init(!CFG) (* create entry/exit *) val ENTRY = hd(#entries cfg ()) val EXIT = hd(#exits cfg ()) fun next(CFG.BLOCK{id,data=ref [],...}::_) = id | next _ = error "next" val lookupLabelMap = Intmap.mapWithDefault(labelMap,EXIT) val TRUE = CFG.BRANCH true val FALSE = CFG.BRANCH false val addEdge = #add_edge cfg fun target(Label.Label{id,...}) = lookupLabelMap id fun addEdges [] = () | addEdges(CFG.BLOCK{id,insns,...}::blocks) = (case !insns of [] => fallsThru(id,blocks) | instr::_ => if InsnProps.instrKind instr = InsnProps.IK_JUMP then jump(id,InsnProps.branchTargets instr,blocks) else fallsThru(id,blocks); addEdges blocks ) and fallsThru(i,CFG.BLOCK{id=j,data,...}::_) = (case !data of [] => () | _ => error("falls thru into pseudo ops: "^ Int.toString i^" -> "^Int.toString j) ; addEdge(i,j,CFG.EDGE{k=CFG.FALLSTHRU,w=ref 0, a=ref []}) ) | fallsThru(i,[]) = (* error("missing return in block "^Int.toString i) *) addEdge(i,EXIT,CFG.EDGE{k=CFG.EXIT,w=ref 0,a=ref []}) and jump(i,[InsnProps.ESCAPES],_) = addEdge(i,EXIT,CFG.EDGE{k=CFG.EXIT,w=ref 0,a=ref []}) | jump(i,[InsnProps.LABELLED L],_) = addEdge(i,target L,CFG.EDGE{k=CFG.JUMP,w=ref 0,a=ref []}) | jump(i,[InsnProps.LABELLED L,InsnProps.FALLTHROUGH],bs) = (addEdge(i,target L,CFG.EDGE{k=TRUE,w=ref 0,a=ref[]}); addEdge(i,next bs,CFG.EDGE{k=FALSE,w=ref 0,a=ref []}) ) | jump(i,[InsnProps.FALLTHROUGH,InsnProps.LABELLED L],bs) = (addEdge(i,target L,CFG.EDGE{k=TRUE,w=ref 0,a=ref []}); addEdge(i,next bs,CFG.EDGE{k=FALSE,w=ref 0,a=ref []}) ) | jump(i,targets,_) = let fun loop(n,[]) = () | loop(n,InsnProps.LABELLED L::targets) = (addEdge(i,target L, CFG.EDGE{k=CFG.SWITCH n,w=ref 0,a=ref []}); loop(n+1,targets)) | loop _ = error "jump" in loop(0,targets) end in addEdges(rev(!newBlocks)); app (fn l => addEdge(ENTRY,target l, CFG.EDGE{k=CFG.ENTRY,a=ref [],w=ref 0})) (!entryLabels); CFG.setAnnotations(!CFG,annotations @ CFG.getAnnotations(!CFG)); init() end fun beginGraph _ = let val regmap = CFG.regmap(!CFG) in init(); aliasF := Intmap.add regmap; regmap end fun alias(v,r) = !aliasF(v,r) in {stream=S.STREAM { beginCluster= beginGraph, endCluster = finish, defineLabel = defineLabel, entryLabel = entryLabel, pseudoOp = pseudoOp, emit = emitInstr, exitBlock = exitBlock, comment = comment, annotation = annotation, alias = alias, phi = can'tUse }, next = next } end end
root@smlnj-gforge.cs.uchicago.edu | ViewVC Help |
Powered by ViewVC 1.0.0 |