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 /MLRISC/trunk/x86/staged-allocation/test.sml
ViewVC logotype

View of /MLRISC/trunk/x86/staged-allocation/test.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3068 - (download) (annotate)
Fri Jun 6 00:25:53 2008 UTC (11 years, 1 month ago) by mrainey
File size: 12812 byte(s)
  Got the prototype up and running.
val fast_floating_point = ref true

(*
 * User defined constant type.  Dummy for now.
 * In practice, you'll want to use this type to implement constants with
 * values that cannot be determined until final code generation, e.g.
 * stack frame offset.
 *)
structure UserConst =
struct
   type const = unit
   fun toString() = ""  
   fun hash() = 0w0  
   fun valueOf _ = 0
   fun == _ = true  
end

(*
 * User defined datatype for representing aliasing.   Dummy for now.
 * You'll need this to represent aliasing information. 
 *)
structure UserRegion =
struct
   type region = unit
   fun toString () = "" 
   val memory = ()
   val stack = ()
   val readonly = ()
   val spill = ()
end

(*
 * User defined datatype for representing pseudo assembly operators.
 * Dummy for now.
 *
 * You'll need this to represent assembler directives. 
 *)
structure UserPseudoOps =
struct
   type pseudo_op = unit  
   fun toString () = ""
   fun emitValue _ = ()
   fun sizeOf _ = 0
   fun adjustLabels _ = true
end



structure C = X86Cells 
structure Cells = C

(*
 * Client defined extensions.  None for now.
 * You'll need this only if you need to extend the set of MLTREE operators
 *)
structure UserExtension =
struct

   type ('s,'r,'f,'c) sx = ('s,'r,'f,'c) X86InstrExt.sext
   type ('s,'r,'f,'c) rx = unit
   type ('s,'r,'f,'c) fx = unit
   type ('s,'r,'f,'c) ccx = unit

end

(*
 * This module controls how we handle user extensions.  Since we don't
 * have any yet.  This is just a bunch of dummy routines.
 *)
functor UserMLTreeExtComp
	    (    structure I : X86INSTR where T.Extension = UserExtension
    structure TS : MLTREE_STREAM where T = I.T
    structure CFG : CONTROL_FLOW_GRAPH where I = I and P = TS.S.P
   ) : MLTREE_EXTENSION_COMP =
struct
    structure T = TS.T
    structure TS = TS
    structure I = I
    structure CFG = CFG
    structure C = I.C

    structure CompInstrExt = X86CompInstrExt (
      structure I = I
      structure TS = TS
      structure CFG = CFG)

    type reducer =
	  (I.instruction,C.cellset,I.operand,I.addressing_mode,CFG.cfg) TS.reducer

    val compileSext = CompInstrExt.compileSext

    fun compileRext _ = raise Fail "CompExtFn.compileRext"
    fun compileFext _ = raise Fail "CompExtFn.compileFext"
    fun compileCCext _ = raise Fail "CompExtFn.compileCCext"

end

structure X86MLTree =
   MLTreeF (structure Constant  = UserConst
    structure Region    = UserRegion
    structure Extension = UserExtension)

structure X86MLTreeEval =
   MLTreeEval (structure T = X86MLTree
    fun eq _ _ = false
    val eqRext = eq val eqFext = eq
    val eqCCext = eq val eqSext = eq)

structure X86GasPseudoOps = 
   X86GasPseudoOps(structure T=X86MLTree
		   structure MLTreeEval=X86MLTreeEval)

(*
functor X86PseudoOpsFn (
    structure T : MLTREE
    structure MLTreeEval : MLTREE_EVAL where T = T
  ) : PSEUDO_OPS_BASIS = X86GasPseudoOps (
    structure T = T
    structure MLTreeEval = MLTreeEval)
*)

functor X86PseudoOpsFn (
    structure T : MLTREE
    structure MLTreeEval : MLTREE_EVAL where T = T
  ) : PSEUDO_OPS_BASIS = X86DarwinPseudoOps (
    structure T = T
    structure MLTreeEval = MLTreeEval)

structure X86PseudoOps = X86PseudoOpsFn(
            structure T = X86MLTree
            structure MLTreeEval = X86MLTreeEval)

structure PseudoOps =
  struct

    structure Client =
      struct
	structure AsmPseudoOps = X86PseudoOps
	type pseudo_op = unit
			 
	fun toString () = ""
  
	fun emitValue _ = raise Fail "todo"
	fun sizeOf _ = raise Fail "todo"
	fun adjustLabels _ = raise Fail "todo"
      end (* Client *)
  
    structure PseudoOps = PseudoOps (structure Client = Client)
  end

structure X86Stream = InstructionStream(PseudoOps.PseudoOps)
structure X86Instr = X86Instr (X86MLTree)
structure X86Shuffle = X86Shuffle(X86Instr)

structure X86MLTreeHash =
   MLTreeHash (structure T = X86MLTree
    fun h _ _ = 0w0
    val hashRext = h val hashFext = h
    val hashCCext = h val hashSext = h)


functor X86MemRegs(X86Instr:X86INSTR) = struct
  structure I = X86Instr
  structure CB = CellsBasis

  fun memReg{reg, base} = raise Fail ""
end

structure X86MemRegs = X86MemRegs(X86Instr)

structure X86Asm = X86AsmEmitter
   (structure Instr = X86Instr
    structure S = X86Stream
    val memRegBase = NONE
    structure MemRegs = X86MemRegs
    structure MLTreeEval = X86MLTreeEval
    structure Shuffle = X86Shuffle
   )

structure X86InsnProps = X86Props 
			  (structure Instr = X86Instr
                           structure MLTreeHash = X86MLTreeHash
			   structure MLTreeEval = X86MLTreeEval)

structure X86CFG = ControlFlowGraph (
            structure I = X86Asm.I
	    structure GraphImpl = DirectedGraph
	    structure InsnProps = X86InsnProps
	    structure Asm = X86Asm)

structure X86MLTStream = MLTreeStream (
		      structure T = X86MLTree
		      structure S = X86Stream)

structure CompInstrExt = X86CompInstrExt (
      structure I = X86Instr
      structure TS = X86MLTStream
      structure CFG = X86CFG)

structure X86MTC = struct
  structure T = X86MLTree
  structure TS = X86MLTStream
  structure I = X86Instr
  structure CFG = X86CFG
  structure C = I.C
   type reducer =
     (I.instruction,C.cellset,I.operand,I.addressing_mode,X86CFG.cfg) TS.reducer
   fun unimplemented _ = MLRiscErrorMsg.impossible "UserMLTreeExtComp"
   val compileSext  = CompInstrExt.compileSext
   val compileRext  = unimplemented
   val compileFext  = unimplemented
   val compileCCext = unimplemented
		      
   structure X86MLTreeUtils : MLTREE_UTILS =
     struct
       structure T = X86MLTree
       structure IX = X86InstrExt
       structure U = MLTreeUtils (
       structure T = T
       fun hashSext _ _ = 0w0
       fun hashRext _ _ = 0w0
       fun hashFext _ _ = 0w0
       fun hashCCext _ _ = 0w0
       fun eqSext _ _ = raise Fail "eqSext"
       fun eqRext _ _ = raise Fail "eqRext"
       fun eqFext _ _ = raise Fail "eqFext"
       fun eqCCext _ _ = raise Fail "eqCCext"
       fun showSext (prt : T.printer) ext = raise Fail "todo"
       fun showRext _ _ = raise Fail "showRext"
       fun showFext _ _ = raise Fail "showFext"
       fun showCCext _ _ = raise Fail "showCCext")
       open U
     end
end

structure X86 = X86 (
		  structure X86Instr = X86Instr
		  structure MLTreeUtils = X86MTC.X86MLTreeUtils
		  structure ExtensionComp = X86MTC
		  structure MLTreeStream = X86MLTStream
           datatype arch = Pentium | PentiumPro | PentiumII | PentiumIII
           val arch = ref Pentium (* Lowest common denominator *)

		  fun cvti2f _ = raise Fail ""
		  val fast_floating_point = fast_floating_point
		  )

structure X86Emit = CFGEmit (
             structure CFG = X86CFG
             structure E = X86Asm) 


structure X86FlowGraph = BuildFlowgraph 
	    (structure Props = X86InsnProps
             structure Stream = X86Stream
	     structure CFG = X86CFG)

structure X86Expand = CFGExpandCopies (structure CFG=X86CFG
                                         structure Shuffle = X86Shuffle)
structure X86BlockPlacement = DefaultBlockPlacement(X86CFG)

structure RASpill = RASpillWithRenaming (
    structure Asm = X86Asm
    structure InsnProps = X86InsnProps
    val max_dist = ref 4
    val keep_multiple_values = ref false)

structure C = X86Cells

datatype spill_operand_kind = SPILL_LOC 
                            | CONST_VAL

datatype ra_phase = SPILL_PROPAGATION 
                  | SPILL_COLORING

  fun upto(from, to) = if from>to then [] else from::(upto (from+1,to))
  infix upto 

structure CB = CellsBasis
structure I = X86Instr

structure IntRA = 
  struct
    val dedicated = [C.esp, C.ebp]
    val allRegs = C.Regs CellsBasis.GP {from=0, to=7, step=1}
    val allRegsSet = foldl C.addReg C.empty allRegs
    val avail = let
        val availSet = List.foldl C.rmvReg allRegsSet dedicated
        in
          C.getReg availSet
        end
    fun spillInit _ = ()
    val memRegs = C.Regs CB.GP {from=8,to=31,step=1}
    fun spillLoc {info=frame, an, cell, id=loc} = let
	    val spillLoc = ~(loc*4)
	    val opnd = I.Displace {
		  base = C.ebp,
		  disp = I.Immed (Int32.fromInt spillLoc),
		  mem = ()
		}
            in
              {opnd = opnd, kind = SPILL_LOC}
            end
    val phases = [SPILL_PROPAGATION, SPILL_COLORING]
  end (* IntRA *)

structure FloatRA =
  struct
    val avail = List.map C.FPReg (0 upto 31)
    val dedicated = []
    fun spillInit _ = ()
    val fastMemRegs = C.Regs CB.FP {from=8, to=31, step=1}
    val fastPhases = [SPILL_PROPAGATION,SPILL_COLORING]
    val memRegs = []
    fun spillLoc (info, ans, id) = raise Fail ""
    val phases = [SPILL_PROPAGATION]
  end (* FloatRA *)

(* register allocation *)
structure X86RA = X86RA (
         structure I = X86Instr
	 structure InsnProps = X86InsnProps
         structure CFG = X86CFG
         structure Asm = X86Asm
         structure SpillHeur = ChowHennessySpillHeur
         structure Spill = RASpill
         structure Props = X86InsnProps
         type spill_info = unit
         fun beforeRA (Graph.GRAPH graph) = ()
         datatype spillOperandKind = datatype spill_operand_kind
	 datatype raPhase = datatype ra_phase
	 val fast_floating_point = fast_floating_point
         structure Int = IntRA
         structure Float = FloatRA)

structure X86Expand = CFGExpandCopies (
    structure CFG=X86CFG
    structure Shuffle = X86Shuffle)


structure CCalls = IA32SVIDFn (
           structure T = X86MLTree
           fun ix x = x
	   val fast_floating_point = fast_floating_point
           val abi = "Darwin")


    structure C = X86Instr.C
    structure T = X86MLTree
    structure CFG = X86CFG
    structure FlowGraph = X86FlowGraph
    structure Vararg = IA32VarargCCallFn(
                       structure T = X86MLTree
                       fun ix x = x
		       val fast_floating_point = fast_floating_point
		       val abi = "Darwin"
		       fun push e = T.EXT(X86InstrExt.PUSHL e)
		       val leave = T.EXT X86InstrExt.LEAVE
		       )

structure TestSA =
  struct
 
    val wordTy = 32

    fun gen (functionName, stms, result) = let
        val insnStrm = FlowGraph.build()
        val stream as X86Stream.STREAM
           { beginCluster,  (* start a cluster *)
             endCluster,    (* end a cluster *)
             emit,          (* emit MLTREE stm *)
             defineLabel,   (* define a local label *)
             entryLabel,    (* define an external entry *)
             exitBlock,     (* mark the end of a procedure *)
             pseudoOp,      (* emit a pseudo op *)
             annotation,    (* add an annotation *)
             ... } =
             X86.selectInstructions insnStrm
   	fun doit () = (
	    beginCluster 0;      (* start a new cluster *)
            pseudoOp PseudoOpsBasisTyp.TEXT;		  
	    pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);    
            entryLabel functionName; (* define the entry label *)
            List.app emit stms; (* emit all the statements *)
            exitBlock result;
            endCluster [])
	val cfg = doit ()
	val cfg = X86RA.run cfg
	val cfg = X86Expand.run cfg
       in
	(cfg, stream)
       end (* gen *)

    fun codegen (functionName, target, proto, initStms, args) = let 
	val [functionName, target] = List.map Label.global [functionName, target]

	(* construct the C call *)
	val {result, callseq} = CCalls.genCall {
	           name=T.LABEL target,
	           paramAlloc=fn _ => false,
	           structRet=fn _ => T.REG (32, Cells.eax),
	           saveRestoreDedicated=fn _ => {save=[], restore=[]},
	           callComment=NONE,
	           proto=proto,
	           args=args}

	fun wordLit i = T.LI (T.I.fromInt (wordTy, i))

	val stms = List.concat [
		   [T.EXT(X86InstrExt.PUSHL(T.REG(32, Cells.ebp))),
		    T.COPY (wordTy, [Cells.ebp], [Cells.esp])],		   
		   initStms,
		   callseq, 
		   [T.EXT(X86InstrExt.LEAVE)],
		   [T.RET []]]


        in  
           gen(functionName, stms, result)
        end (* codegen *)

    fun dumpOutput (cfg, stream) = let
	val (cfg as Graph.GRAPH graph, blocks) = 
		X86BlockPlacement.blockPlacement cfg
	val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
	in
	  X86Emit.asmEmit (cfg, blocks)
	end (* dumpOutput *)

   fun vararg _ = let
           val _ = Label.reset()
	   val (lab, stms) = Vararg.genVarargs()	          
	   val asmOutStrm = TextIO.openOut "mlrisc.s"
	   fun doit () = dumpOutput(gen(lab, stms, [T.GPR (T.REG (wordTy, C.eax))]))
	   val _ = AsmStream.withStream asmOutStrm doit ()
	   val _ = TextIO.closeOut asmOutStrm
           in
	      0
	   end

  end

    (* machine-specific data *)
    val wordTy = 32
    val wordSzB = wordTy div 8
    fun li i = T.LI (T.I.fromInt (wordTy, i))
    val param0 = T.LOAD(wordTy, T.ADD(32, li 8, T.REG(32,Cells.ebp)), ())

  structure CSizes = IA32CSizes


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