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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1014 - (download) (annotate)
Tue Jan 15 16:32:43 2002 UTC (18 years, 8 months ago) by jhr
File size: 10142 byte(s)
  Added code for BSS and SPACE pseudo-ops.
(* buildFlowgraph.sml
 *
 * COPYRIGHT (c) 2001 Bell Labs, Lucent Technologies
 *)
signature CONTROL_FLOWGRAPH_GEN =
sig

   structure S   : INSTRUCTION_STREAM
   structure I   : INSTRUCTIONS
   structure P   : PSEUDO_OPS
   structure CFG : CONTROL_FLOW_GRAPH
   		where I = I
                  and P = P
   (*
    * This creates an emitter which can be used to build a CFG incrementally
    *)
   type instrStream = 
     (I.instruction, Annotations.annotations, I.C.cellset, CFG.cfg) S.stream

   val build : unit -> instrStream

end




functor BuildFlowgraph 
  (structure Props  : INSN_PROPERTIES
   structure Stream : INSTRUCTION_STREAM
   structure CFG    : CONTROL_FLOW_GRAPH  
			  where I = Props.I
			    and P = Stream.P
  ) : CONTROL_FLOWGRAPH_GEN =
struct
  structure CFG = CFG
  structure P = CFG.P
  structure I = Props.I
  structure G = Graph
  structure S = Stream
  structure Fmt = Format
  structure PB  = PseudoOpsBasisTyp

  exception LabelNotFound

  type instrStream = 
     (I.instruction, Annotations.annotations, CFG.I.C.cellset, CFG.cfg) S.stream

  fun error msg = MLRiscErrorMsg.error ("BuildFlowGraph", msg)

  val hashLabel = Word.toInt o Label.hash

  fun build ()  = let
    val cfg as ref(G.GRAPH graph) = ref(CFG.new())
   
    (* list of blocks generated so far *)
    val blockList   = ref ([] : CFG.block list)

    (* list of entry labels to patch successors of ENTRY *)
    val entryLabels = ref ([] : Label.label list)
   
    (* block id associated with a label*)
    val labelMap    = IntHashTable.mkTable(32, LabelNotFound)
    val findLabel   = IntHashTable.find labelMap
    val addLabel    = IntHashTable.insert labelMap

    (* Data in text segment is read-only *)
    datatype segment_t = TEXT | DATA | RO_DATA | BSS
    val segmentF    = ref TEXT

    (* the block names *)
    val blockNames   = ref [] : Annotations.annotations ref

    (* can instructions be reordered *)
    val reorder      = ref [] : Annotations.annotations ref

    (* noblock or invalid block has id of ~1 *)
    val noBlock = CFG.newBlock(~1, ref 0)

    (* current block being built up *)
    val currentBlock = ref noBlock


    (* add a new block and make it the current block being built up *)
    fun newBlock(freq) = let
      val G.GRAPH graph = !cfg
      val id = #new_id graph ()
      val blk as CFG.BLOCK{annotations, ...} = CFG.newBlock(id, ref freq)
    in
      currentBlock := blk;
      annotations := !blockNames @ !reorder;
      blockList := blk :: !blockList;
      #add_node graph (id, blk);
      blk
    end


    (* get current basic block *)
    fun getBlock () = 
     (case !currentBlock of CFG.BLOCK{id= ~1, ...} => newBlock(1) | blk => blk)


    (* ------------------------cluster---------------------------*)
    (* start a new cluster *)
    fun beginCluster _ = 
      (blockList := [];
       entryLabels := [];
       IntHashTable.clear labelMap;
       blockNames := [];
       currentBlock := noBlock)

    (* emit an instruction *)
    fun emit i = let
      val CFG.BLOCK{insns, ...} = getBlock()
      fun terminate() = currentBlock := noBlock;
    in 
      insns := i:: !insns;
      case Props.instrKind(i)
      of Props.IK_JUMP => terminate()
       | Props.IK_CALL_WITH_CUTS => terminate()
       | _ => ()
      (*esac*)
    end

    (* make current block an exit block *)
    fun exitBlock liveout = let
      fun setLiveOut(CFG.BLOCK{annotations, ...}) = 
	annotations := #create CFG.LIVEOUT liveout :: !annotations
    in 
      case !currentBlock
       of CFG.BLOCK{id= ~1, ...} =>
	   (case !blockList
	     of [] => error "exitBlocks"
	      | blk::_ => setLiveOut blk
	   (*esac*))
        | blk => setLiveOut blk
    end (* exitBlock *)


    (* end cluster --- all done *)
    fun endCluster (annotations) = let
      val cfg as G.GRAPH graph = (!cfg before cfg := CFG.new())
      val _ = CFG.init(cfg)		(* create unique ENTRY/EXIT nodes *)

      val ENTRY = hd(#entries graph ())
      val EXIT = hd(#exits graph ())

      fun addEdge(from, to, kind) =
	#add_edge graph (from, to, CFG.EDGE{k=kind, w=ref 0, a=ref[]})

      fun target lab =
	(case (IntHashTable.find labelMap (hashLabel lab))
	  of SOME bId => bId 
	   | NONE => EXIT)

      fun jump(from, [Props.ESCAPES], _) = addEdge(from, EXIT, CFG.FALLSTHRU)
	| jump(from, [Props.LABELLED lab], _) = addEdge(from, target lab, CFG.JUMP)
	| jump(from, [Props.LABELLED lab, Props.FALLTHROUGH], blks) = let
	   fun next(CFG.BLOCK{id, ...}::_) = id
	     | next [] = error "jump.next"
          in
	    addEdge(from, target lab, CFG.BRANCH true);
	    addEdge(from, next blks, CFG.BRANCH false)
	  end
	| jump(from, [f as Props.FALLTHROUGH, l as Props.LABELLED _], blks) = 
	    jump(from, [l, f], blks)
	| jump(from, targets, _) = let
	    fun switch(Props.LABELLED lab, n) = 
	         (addEdge(from, target lab, CFG.SWITCH(n)); n+1)
	      | switch _ = error "jump.switch"
          in List.foldl switch 0 targets; ()
          end

      and fallsThru(id, blks) = let
	fun fallThruEdge(to) = addEdge (id, to, CFG.FALLSTHRU)
      in
	case blks
	 of [] => fallThruEdge(EXIT)
          | CFG.BLOCK{id=next, insns=ref(_::_), (*data=ref[], JHR *) ...}::_ => fallThruEdge(next)
	  | CFG.BLOCK{id=next, ...} ::_ => error 
	     (* if pseudo ops are alignment directives, this may not be an error *)
	     (Fmt.format "Block %d falls through to pseudoOps in %d\n"
	        [Fmt.INT id, Fmt.INT next])
      end
	     
      and addEdges [] = ()
	| addEdges(CFG.BLOCK{id, insns=ref[], ...}::blocks) = fallsThru(id, blocks)
	| addEdges(CFG.BLOCK{id, insns=ref(instr::_), ...}::blocks) = let
	    fun doJmp () = jump(id, Props.branchTargets instr, blocks)
          in
	   case Props.instrKind instr
	    of Props.IK_JUMP => doJmp()
	     | Props.IK_CALL_WITH_CUTS => doJmp()
	     | _ => fallsThru(id, blocks)
	   (*esac*);
	   addEdges(blocks)
          end
    in
      addEdges (rev(!blockList));
      app (fn lab => addEdge(ENTRY, target lab, CFG.ENTRY)) (!entryLabels);
      let val an = CFG.annotations cfg in  an := annotations @ (!an) end;
      cfg
    end (* endCluster *)

    
    (* ------------------------annotations-----------------------*)
    (* XXX: Bug: EMPTYBLOCK does not really generate an empty block 
     *	but merely terminates the current block. Contradicts the comment
     *  in instructions/mlriscAnnotations.sig.
     *  It should be (newBlock(1); newBlock(1); ())
     *)

    (* Add a new annotation *)
    fun addAnnotation a = 
     (case a 
       of MLRiscAnnotations.BLOCKNAMES names =>
	   (blockNames := names;  newBlock(1); ())
        | MLRiscAnnotations.EMPTYBLOCK => (newBlock(1); ())
	| MLRiscAnnotations.EXECUTIONFREQ f => 
	   (case !currentBlock
	     of CFG.BLOCK{id= ~1, ...} => (newBlock(f); ())
	      | CFG.BLOCK{freq, ...} => freq := f
           (*esac*))
	| a => let 
	     val CFG.BLOCK{annotations,...} = getBlock()
           in  annotations := a :: !annotations
	   end
     (*esac*))

    (* get annotation associated with flow graph *)
    fun getAnnotations () = CFG.annotations(!cfg)

    (* add a comment annotation to the current block *)
    fun comment msg = addAnnotation (#create MLRiscAnnotations.COMMENT msg)


    (* -------------------------labels---------------------------*)
    (* BUG: Does not respect any ordering between labels and pseudoOps. 
     * This could be a problem with jump tables. 
     *)
    fun addPseudoOp p = let
      val Graph.GRAPH graph = !cfg
      val CFG.INFO{data, ...} = #graph_info graph

      fun addAlignment () = let
	val CFG.BLOCK{align, ...} = newBlock(1)
      in align := SOME p
      end
 
      fun startSegment(seg) = (data := p :: !data; segmentF := seg)

      fun addData(seg) =
	(case !segmentF
         of TEXT => 
	     error (Fmt.format "addPseudoOp: %s in TEXT segment" [Fmt.STR seg])
          | _ => data := p :: !data
        (*esac*))
    in
      case p
      of PB.ALIGN_SZ _ => addAlignment()
       | PB.ALIGN_ENTRY => addAlignment()
       | PB.ALIGN_LABEL => addAlignment()
       | PB.DATA_LABEL _ =>
	   (case !segmentF 
	    of TEXT => error "addPseudoOp: DATA_LABEL in TEXT segment"
             | _ => (data := p:: !data)
           (*esac*))

       | PB.DATA_READ_ONLY => startSegment(RO_DATA)
       | PB.DATA => startSegment(DATA)
       | PB.TEXT => startSegment(TEXT)
       | PB.BSS => startSegment(BSS)
       | PB.SECTION _ => 
	  (case !segmentF
	    of TEXT => error "addPseudoOp: SECTION in TEXT segment"
             | _ => data := p :: !data
          (*esac*))
       | PB.REORDER => (reorder := []; newBlock(1); ())
       | PB.NOREORDER => 
	   (reorder := [#create MLRiscAnnotations.NOREORDER ()]; newBlock(1); ())
  
       | PB.INT _    => addData("INT")
       | PB.FLOAT _  => addData("FLOAT")
       | PB.ASCII _  => addData("ASCII")
       | PB.ASCIIZ _ => addData("ASCIIZ")
       | PB.SPACE _  => addData("SPACE")
       | PB.IMPORT _ => addData("IMPORT")
       | PB.EXPORT _ => addData("EXPORT")
       | PB.EXT _ => addData("EXT")
    end

    fun defineLabel lab = 
      (case findLabel (hashLabel lab)
        of NONE => let
	     fun newBlk () = 
	       (case !currentBlock
                 of CFG.BLOCK{id= ~1, ...} => newBlock(1)
		  | CFG.BLOCK{insns=ref[], ...} => !currentBlock (* probably aligned block *)
		  | _ => newBlock(1)
               (*esac*))
             val CFG.BLOCK{id, labels, ...} = newBlk()
	   in 
	       labels := lab :: !labels;
	       addLabel(hashLabel lab, id)
           end

	 | SOME _ => 
	     error (concat
	       ["multiple definitions of label \"", Label.toString lab, "\""])
	  (*esac*))
      
    fun entryLabel lab = (defineLabel lab; entryLabels := lab :: !entryLabels)
  in
    S.STREAM
      { 
         comment       = comment,
         getAnnotations= getAnnotations,
         annotation    = addAnnotation,
         defineLabel   = defineLabel,
         entryLabel    = entryLabel,
         pseudoOp      = addPseudoOp,
         beginCluster  = beginCluster,
         emit          = emit,
         exitBlock     = exitBlock,
         endCluster    = endCluster
      }
  end
end

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