Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/MLRISC/flowgraph/buildFlowgraph.sml
ViewVC logotype

Diff of /sml/trunk/src/MLRISC/flowgraph/buildFlowgraph.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 983, Wed Nov 21 18:44:55 2001 UTC revision 984, Wed Nov 21 19:00:08 2001 UTC
# Line 2  Line 2 
2   *   *
3   * COPYRIGHT (c) 2001 Bell Labs, Lucent Technologies   * COPYRIGHT (c) 2001 Bell Labs, Lucent Technologies
4   *)   *)
   
5  signature CONTROL_FLOWGRAPH_GEN =  signature CONTROL_FLOWGRAPH_GEN =
6  sig  sig
7    
8     structure S   : INSTRUCTION_STREAM     structure S   : INSTRUCTION_STREAM
9     structure I   : INSTRUCTIONS     structure I   : INSTRUCTIONS
10       structure P   : PSEUDO_OPS
11     structure CFG : CONTROL_FLOW_GRAPH     structure CFG : CONTROL_FLOW_GRAPH
12                  where I = I                  where I = I
13                    and P = S.P                    and P = P
14     (*     (*
15      * This creates an emitter which can be used to build a CFG incrementally      * This creates an emitter which can be used to build a CFG incrementally
16      *)      *)
# Line 21  Line 21 
21    
22  end  end
23    
24    
25    
26    
27  functor BuildFlowgraph  functor BuildFlowgraph
28    (structure Props  : INSN_PROPERTIES    (structure Props  : INSN_PROPERTIES
29     structure Stream : INSTRUCTION_STREAM     structure Stream : INSTRUCTION_STREAM
30     structure CFG    : CONTROL_FLOW_GRAPH     structure CFG    : CONTROL_FLOW_GRAPH
31       sharing CFG.P = Stream.P                            where I = Props.I
32           and CFG.I = Props.I                              and P = Stream.P
33    ) : CONTROL_FLOWGRAPH_GEN =    ) : CONTROL_FLOWGRAPH_GEN =
34  struct  struct
35    structure CFG = CFG    structure CFG = CFG
36      structure P = CFG.P
37    structure I = Props.I    structure I = Props.I
   structure P = Props  
38    structure G = Graph    structure G = Graph
39    structure S = Stream    structure S = Stream
40    structure Fmt = Format    structure Fmt = Format
41    exception LabelNotFound    structure PB  = PseudoOpsBasisTyp
42    
43    fun dummy (x: CFG.I.C.cellset) = x : Props.I.C.cellset    exception LabelNotFound
44    
45    type instrStream =    type instrStream =
46       (I.instruction, Annotations.annotations, CFG.I.C.cellset, CFG.cfg) S.stream       (I.instruction, Annotations.annotations, CFG.I.C.cellset, CFG.cfg) S.stream
# Line 54  Line 57 
57    
58      (* list of entry labels to patch successors of ENTRY *)      (* list of entry labels to patch successors of ENTRY *)
59      val entryLabels = ref ([] : Label.label list)      val entryLabels = ref ([] : Label.label list)
60    
61      (* block id associated with a label*)      (* block id associated with a label*)
62      val labelMap    = IntHashTable.mkTable(32, LabelNotFound)      val labelMap    = IntHashTable.mkTable(32, LabelNotFound)
63      val findLabel   = IntHashTable.find labelMap      val findLabel   = IntHashTable.find labelMap
64      val addLabel    = IntHashTable.insert labelMap      val addLabel    = IntHashTable.insert labelMap
65    
66      (* the block name annotation *)      (* Data in text segment is read-only *)
67        datatype segment_t = TEXT | DATA | RO_DATA
68        val segmentF    = ref TEXT
69    
70        (* the block names *)
71      val blockNames   = ref [] : Annotations.annotations ref      val blockNames   = ref [] : Annotations.annotations ref
72    
73        (* can instructions be reordered *)
74        val reorder      = ref [] : Annotations.annotations ref
75    
76      (* noblock or invalid block has id of ~1 *)      (* noblock or invalid block has id of ~1 *)
77      val noBlock = CFG.newBlock(~1, ref 0)      val noBlock = CFG.newBlock(~1, ref 0)
78    
79      (* current block being built up *)      (* current block being built up *)
80      val currentBlock = ref noBlock      val currentBlock = ref noBlock
81    
     (* initialize state *)  
     fun init () = let  
       val G.GRAPH cfg = !cfg  
     in  
        blockList := [];  
        entryLabels := [];  
        IntHashTable.clear labelMap;  
        blockNames := [];  
        currentBlock := noBlock  
     end  
   
82    
83      (* add a new block and make it the current block being built up *)      (* add a new block and make it the current block being built up *)
84      fun newBlock(freq) = let      fun newBlock(freq) = let
# Line 86  Line 87 
87        val blk as CFG.BLOCK{annotations, ...} = CFG.newBlock(id, ref freq)        val blk as CFG.BLOCK{annotations, ...} = CFG.newBlock(id, ref freq)
88      in      in
89        currentBlock := blk;        currentBlock := blk;
90        annotations := !blockNames;        annotations := !blockNames @ !reorder;
91        blockList := blk :: !blockList;        blockList := blk :: !blockList;
92        #add_node graph (id, blk);        #add_node graph (id, blk);
93        blk        blk
# Line 100  Line 101 
101    
102      (* ------------------------cluster---------------------------*)      (* ------------------------cluster---------------------------*)
103      (* start a new cluster *)      (* start a new cluster *)
104      fun beginCluster _ = init()      fun beginCluster _ =
105          (blockList := [];
106           entryLabels := [];
107           IntHashTable.clear labelMap;
108           blockNames := [];
109           currentBlock := noBlock)
110    
111      (* emit an instruction *)      (* emit an instruction *)
112      fun emit i = let      fun emit i = let
# Line 150  Line 156 
156          | jump(from, [Props.LABELLED lab], _) = addEdge(from, target lab, CFG.JUMP)          | jump(from, [Props.LABELLED lab], _) = addEdge(from, target lab, CFG.JUMP)
157          | jump(from, [Props.LABELLED lab, Props.FALLTHROUGH], blks) = let          | jump(from, [Props.LABELLED lab, Props.FALLTHROUGH], blks) = let
158             fun next(CFG.BLOCK{id, ...}::_) = id             fun next(CFG.BLOCK{id, ...}::_) = id
159                 | next [] = error "jump.next"
160            in            in
161              addEdge(from, target lab, CFG.BRANCH true);              addEdge(from, target lab, CFG.BRANCH true);
162              addEdge(from, next blks, CFG.BRANCH false)              addEdge(from, next blks, CFG.BRANCH false)
# Line 194  Line 201 
201        cfg        cfg
202      end (* endCluster *)      end (* endCluster *)
203    
     (* -------------------------labels---------------------------*)  
     (* BUG: Does not respect any ordering between labels and pseudoOps.  
      * This could be a problem with jump tables.  
      *)  
     fun newPseudoOpBlock() =  
      (case !currentBlock  
        of CFG.BLOCK{id= ~1,...} => newBlock(1)  
         |  b as CFG.BLOCK{insns=ref [],...} => b  
         |  _ => newBlock(1)  
      (*esac*))  
   
     fun addPseudoOp p =  
     let val CFG.BLOCK{data, labels, ...} = newPseudoOpBlock()  
     in  data := !data @ map CFG.LABEL(!labels) @ [CFG.PSEUDO p];  
         labels := []  
     end  
   
     fun defineLabel lab = (case findLabel (hashLabel lab)  
            of NONE => let  
                 val CFG.BLOCK{id, labels, data, ...} = newPseudoOpBlock()  
                 in  
                   labels := lab :: !labels;  
                   addLabel(hashLabel lab, id)  
                 end  
             | SOME _ => error (concat[  
                   "multiple definitions of label \"", Label.toString lab, "\""  
                 ])  
           (* end case *))  
   
     fun entryLabel lab = (defineLabel lab; entryLabels := lab :: !entryLabels)  
   
   
   
204    
205      (* ------------------------annotations-----------------------*)      (* ------------------------annotations-----------------------*)
206      (* XXX: Bug: EMPTYBLOCK does not really generate an empty block      (* XXX: Bug: EMPTYBLOCK does not really generate an empty block
207       *  but merely terminates the current block. Contradicts the comment       *  but merely terminates the current block. Contradicts the comment
208       *  in instructions/mlriscAnnotations.sig.       *  in instructions/mlriscAnnotations.sig.
209         *  It should be (newBlock(1); newBlock(1); ())
210       *)       *)
211    
212      (* Add a new annotation *)      (* Add a new annotation *)
# Line 256  Line 231 
231    
232      (* add a comment annotation to the current block *)      (* add a comment annotation to the current block *)
233      fun comment msg = addAnnotation (#create MLRiscAnnotations.COMMENT msg)      fun comment msg = addAnnotation (#create MLRiscAnnotations.COMMENT msg)
234    
235    
236        (* -------------------------labels---------------------------*)
237        (* BUG: Does not respect any ordering between labels and pseudoOps.
238         * This could be a problem with jump tables.
239         *)
240        fun addPseudoOp p = let
241          val Graph.GRAPH graph = !cfg
242          val CFG.INFO{data, ...} = #graph_info graph
243    
244          fun addAlignment () = let
245            val CFG.BLOCK{align, ...} = newBlock(1)
246          in align := SOME p
247          end
248    
249          fun startSegment(seg) = (data := p :: !data; segmentF := seg)
250    
251          fun addData(seg) =
252            (case !segmentF
253             of TEXT =>
254                 error (Fmt.format "addPseudoOp: %s in TEXT segment" [Fmt.STR seg])
255              | _ => data := p :: !data
256            (*esac*))
257        in
258          case p
259          of PB.ALIGN_SZ _ => addAlignment()
260           | PB.ALIGN_ENTRY => addAlignment()
261           | PB.ALIGN_LABEL => addAlignment()
262           | PB.DATA_LABEL _ =>
263               (case !segmentF
264                of TEXT => error "addPseudoOp: DATA_LABEL in TEXT segment"
265                 | _ => (data := p:: !data)
266               (*esac*))
267    
268           | PB.DATA_READ_ONLY => startSegment(RO_DATA)
269           | PB.DATA => startSegment(DATA)
270           | PB.TEXT => startSegment(TEXT)
271           | PB.SECTION _ =>
272              (case !segmentF
273                of TEXT => error "addPseudoOp: SECTION in TEXT segment"
274                 | _ => data := p :: !data
275              (*esac*))
276           | PB.REORDER => (reorder := []; newBlock(1); ())
277           | PB.NOREORDER =>
278               (reorder := [#create MLRiscAnnotations.NOREORDER ()]; newBlock(1); ())
279    
280           | PB.INT _    => addData("INT")
281           | PB.FLOAT _  => addData("FLOAT")
282           | PB.ASCII _  => addData("ASCII")
283           | PB.ASCIIZ _ => addData("ASCIIZ")
284           | PB.IMPORT _ => addData("IMPORT")
285           | PB.EXPORT _ => addData("EXPORT")
286           | PB.EXT _ => addData("EXT")
287        end
288    
289        fun defineLabel lab =
290          (case findLabel (hashLabel lab)
291            of NONE => let
292                 fun newBlk () =
293                   (case !currentBlock
294                     of CFG.BLOCK{id= ~1, ...} => newBlock(1)
295                      | CFG.BLOCK{insns=ref[], ...} => !currentBlock (* probably aligned block *)
296                      | _ => newBlock(1)
297                   (*esac*))
298                 val CFG.BLOCK{id, labels, ...} = newBlk()
299               in
300                   labels := lab :: !labels;
301                   addLabel(hashLabel lab, id)
302               end
303    
304             | SOME _ =>
305                 error (concat
306                   ["multiple definitions of label \"", Label.toString lab, "\""])
307              (*esac*))
308    
309        fun entryLabel lab = (defineLabel lab; entryLabels := lab :: !entryLabels)
310    in    in
311      S.STREAM      S.STREAM
312        {        {

Legend:
Removed from v.983  
changed lines
  Added in v.984

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0