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

Diff of /MLRISC/trunk/amd64/staged-allocation/test.sml

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

MLRISC/trunk/staged-allocation/test-staged-allocation-amd64.sml revision 2993, Thu Apr 17 01:02:19 2008 UTC MLRISC/trunk/amd64/staged-allocation/test.sml revision 3058, Tue Jun 3 17:17:28 2008 UTC
# Line 1  Line 1 
1    (*
2     * User defined constant type.  Dummy for now.
3     * In practice, you'll want to use this type to implement constants with
4     * values that cannot be determined until final code generation, e.g.
5     * stack frame offset.
6     *)
7    structure UserConst =
8    struct
9       type const = unit
10       fun toString() = ""
11       fun hash() = 0w0
12       fun valueOf _ = 0
13       fun == _ = true
14    end
15    
16    (*
17     * User defined datatype for representing aliasing.   Dummy for now.
18     * You'll need this to represent aliasing information.
19     *)
20    structure UserRegion =
21    struct
22       type region = unit
23       fun toString () = ""
24       val memory = ()
25       val stack = ()
26       val readonly = ()
27       val spill = ()
28    end
29    
30    (*
31     * User defined datatype for representing pseudo assembly operators.
32     * Dummy for now.
33     *
34     * You'll need this to represent assembler directives.
35     *)
36    structure UserPseudoOps =
37    struct
38       type pseudo_op = unit
39       fun toString () = ""
40       fun emitValue _ = ()
41       fun sizeOf _ = 0
42       fun adjustLabels _ = true
43    end
44    
45    
46    
47    (*
48     * Client defined extensions.  None for now.
49     * You'll need this only if you need to extend the set of MLTREE operators
50     *)
51    structure UserExtension =
52    struct
53    
54       type ('s,'r,'f,'c) sx = ('s,'r,'f,'c) AMD64InstrExt.sext
55       type ('s,'r,'f,'c) rx = unit
56       type ('s,'r,'f,'c) fx = unit
57       type ('s,'r,'f,'c) ccx = unit
58    
59    end
60    
61    (*
62     * This module controls how we handle user extensions.  Since we don't
63     * have any yet.  This is just a bunch of dummy routines.
64     *)
65    functor UserMLTreeExtComp
66                (    structure I : AMD64INSTR where T.Extension = UserExtension
67        structure TS : MLTREE_STREAM where T = I.T
68        structure CFG : CONTROL_FLOW_GRAPH where I = I and P = TS.S.P
69       ) : MLTREE_EXTENSION_COMP =
70    struct
71        structure T = TS.T
72        structure TS = TS
73        structure I = I
74        structure CFG = CFG
75        structure C = I.C
76    
77        structure CompInstrExt = AMD64CompInstrExt (
78          structure I = I
79          structure TS = TS
80          structure CFG = CFG)
81    
82        type reducer =
83              (I.instruction,C.cellset,I.operand,I.addressing_mode,CFG.cfg) TS.reducer
84    
85        val compileSext = CompInstrExt.compileSext
86    
87        fun compileRext _ = raise Fail "AMD64CompExtFn.compileRext"
88        fun compileFext _ = raise Fail "AMD64CompExtFn.compileFext"
89        fun compileCCext _ = raise Fail "AMD64CompExtFn.compileCCext"
90    
91    end
92    
93  val floats16ByteAligned = true  val floats16ByteAligned = true
94    
95  structure AMD64MLTree =  structure AMD64MLTree =
# Line 105  Line 197 
197              structure InsnProps = AMD64InsnProps              structure InsnProps = AMD64InsnProps
198              structure Asm = AMD64Asm)              structure Asm = AMD64Asm)
199    
 (*structure AMD64Stream = InstructionStream(AMD64PseudoOps)*)  
200  structure AMD64MLTStream = MLTreeStream (  structure AMD64MLTStream = MLTreeStream (
201                        structure T = AMD64MLTree                        structure T = AMD64MLTree
202                        structure S = AMD64Stream)                        structure S = AMD64Stream)
# Line 200  Line 291 
291          end          end
292      fun spillInit _ = ()      fun spillInit _ = ()
293      fun spillLoc {info=frame, an, cell, id=loc} =      fun spillLoc {info=frame, an, cell, id=loc} =
294          {opnd = AMD64Instr.Immed 0, kind = SPILL_LOC}  raise Fail ""
295    (*        {opnd = AMD64Instr.Immed 0, kind = SPILL_LOC}*)
296      val phases = [SPILL_PROPAGATION, SPILL_COLORING]      val phases = [SPILL_PROPAGATION, SPILL_COLORING]
297    end (* IntRA *)    end (* IntRA *)
298    
# Line 209  Line 301 
301      val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}      val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
302      val dedicated = []      val dedicated = []
303      fun spillInit _ = ()      fun spillInit _ = ()
304      fun spillLoc (info, ans, id) = AMD64Instr.Immed 0      fun spillLoc (info, ans, id) = raise Fail ""
305      val phases = [SPILL_PROPAGATION, SPILL_COLORING]      val phases = [SPILL_PROPAGATION, SPILL_COLORING]
306    end (* FloatRA *)    end (* FloatRA *)
307    
# Line 233  Line 325 
325      structure CFG=AMD64CFG      structure CFG=AMD64CFG
326      structure Shuffle = AMD64Shuffle)      structure Shuffle = AMD64Shuffle)
327    
328  structure CCalls = AMD64SVID (  structure CCalls = AMD64SVIDFn (
329                        structure T = AMD64MLTree)
330    
331    
332    structure OldCCalls = AMD64SVID (
333             structure T = AMD64MLTree             structure T = AMD64MLTree
334             val frameAlign = 16)             val frameAlign = 16)
335    
336    
337    structure RA2 =
338        RISC_RA
339        (structure I = AMD64Instr
340         structure Asm = AMD64Asm
341         structure CFG = AMD64CFG
342         structure InsnProps = AMD64InsnProps
343         structure Rewrite =
344           struct
345             structure I = AMD64Instr
346             structure C=I.C
347             structure CB = CellsBasis
348             fun error msg = MLRiscErrorMsg.error("X86Rewrite", msg)
349    
350             fun operand (rs,rt) opnd =
351                 (case opnd
352                   of I.Direct (sz, r) => if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
353                    | I.Displace{base, disp, mem} =>
354                      if CB.sameColor(base,rs) then I.Displace{base=rt, disp=disp, mem=mem}
355                      else opnd
356                    | I.Indexed{base as SOME b, index, scale, disp, mem} => let
357                          val base'= if CB.sameColor(b,rs) then SOME rt else base
358                          val index'=if CB.sameColor(index,rs) then rt else index
359                      in I.Indexed{base=base', index=index', scale=scale, disp=disp, mem=mem}
360                      end
361                    | I.Indexed{base, index, scale, disp, mem=mem}  =>
362                      if CB.sameColor(index,rs) then
363                          I.Indexed{base=base, index=rt, scale=scale, disp=disp, mem=mem}
364                      else opnd
365                    | _ => opnd
366                  (*end case*))
367    
368    
369             fun rewriteDef (instr, rs, rt) = let
370                 fun operand(opnd as I.Direct (sz, r)) =
371                     if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
372                   | operand _ = error "operand: not I.Direct"
373                 fun replace r = if CB.sameColor(r,rs) then rt else r
374                 fun rewriteX86Def(instr) =
375                     (case instr
376                       of I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
377                          I.CALL{opnd=opnd, cutsTo=cutsTo,
378                                 return=CB.CellSet.map {from=rs,to=rt} return, pops=pops,
379                                 defs=CB.CellSet.map {from=rs,to=rt} defs, uses=uses, mem=mem}
380                        | I.MOVE{mvOp, src, dst} => I.MOVE{mvOp=mvOp, src=src, dst=operand dst}
381                        | I.LEAL{r32, addr} => I.LEAL{r32=replace r32, addr=addr}
382                        | I.LEAQ{r64, addr} => I.LEAQ{r64=replace r64, addr=addr}
383                        | I.BINARY{binOp, src, dst} =>
384                          I.BINARY{binOp=binOp, src=src, dst=operand dst}
385                        | I.SHIFT{shiftOp, src, dst, count} =>
386                          I.SHIFT{shiftOp=shiftOp, src=src, count=count, dst=operand dst}
387                        | I.UNARY{unOp, opnd} => I.UNARY{unOp=unOp, opnd=operand opnd}
388                        | I.SET{cond, opnd} => I.SET{cond=cond, opnd=operand opnd}
389                        | _ => instr
390                    (* end case *))
391    
392                 fun f (I.ANNOTATION{a,i}) =
393                     I.ANNOTATION{i=rewriteDef(i,rs,rt),
394                                  a=(case a of
395                                         CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
396                                         CB.DEF_USE{cellkind=CB.GP,uses=uses,
397                                                    defs=map replace defs}
398                                       | _ => a)}
399                   | f (I.INSTR i) = I.INSTR(rewriteX86Def(i))
400                   | f (I.COPY{k as CB.GP, sz, dst, src, tmp}) =
401                     I.COPY{k=k, sz=sz, dst=map replace dst, src=src, tmp=tmp}
402             in
403                 f(instr)
404             end
405    
406    
407             fun rewriteUse (instr, rs, rt) = let
408                 val operand = operand (rs, rt)
409                 fun replace r = if CB.sameColor(r,rs) then rt else r
410                 fun rewrite instr = (case instr
411                     of I.JMP(opnd, labs) => I.JMP(operand opnd, labs)
412                      | I.JCC{cond, opnd} => I.JCC{cond=cond, opnd = operand opnd}
413                      | I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
414                        I.CALL{opnd=operand opnd, defs=defs, return=return,
415                               uses=CB.CellSet.map {from=rs,to=rt} uses, cutsTo=cutsTo,
416                               mem=mem, pops=pops}
417                      | I.MOVE{mvOp, src, dst as I.Direct _} =>
418                        I.MOVE{mvOp=mvOp, src=operand src, dst=dst}
419                      | I.MOVE{mvOp, src, dst} =>
420                        I.MOVE{mvOp=mvOp, src=operand src, dst=operand dst}
421                      | I.LEAL{r32, addr} => I.LEAL{r32=r32, addr=operand addr}
422                      | I.LEAQ{r64, addr} => I.LEAQ{r64=r64, addr=operand addr}
423                      | I.CMPL{lsrc, rsrc} => I.CMPL{lsrc=operand lsrc, rsrc=operand rsrc}
424                      | I.CMPW{lsrc, rsrc} => I.CMPW{lsrc=operand lsrc, rsrc=operand rsrc}
425                      | I.CMPB{lsrc, rsrc} => I.CMPB{lsrc=operand lsrc, rsrc=operand rsrc}
426                      | I.TESTL{lsrc, rsrc} => I.TESTL{lsrc=operand lsrc, rsrc=operand rsrc}
427                      | I.TESTW{lsrc, rsrc} => I.TESTW{lsrc=operand lsrc, rsrc=operand rsrc}
428                      | I.TESTB{lsrc, rsrc} => I.TESTB{lsrc=operand lsrc, rsrc=operand rsrc}
429                      | I.BITOP{bitOp, lsrc, rsrc} =>
430                        I.BITOP{bitOp=bitOp, lsrc=operand lsrc, rsrc=operand rsrc}
431                      | I.BINARY{binOp, src, dst} =>
432                        I.BINARY{binOp=binOp, src=operand src, dst=operand dst}
433                      | I.SHIFT{shiftOp, src, dst, count} =>
434                        I.SHIFT{shiftOp=shiftOp, src=operand src, dst=operand dst,
435                                count=operand src}
436                    (* end case *))
437    
438                 fun f(I.ANNOTATION{a,i}) =
439                     I.ANNOTATION{i=rewriteUse(i, rs, rt),
440                                  a = case a of
441                                          CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
442                                          CB.DEF_USE{cellkind=CB.GP,uses=map replace uses,
443                                                     defs=defs}
444                                        | _ => a}
445                   | f(I.INSTR i) = I.INSTR(rewrite(i))
446                   | f(I.COPY{k as CB.GP, sz, dst, src, tmp}) =
447                     I.COPY{k=k, sz=sz, dst=dst, src=List.map replace src, tmp=tmp}
448             in
449                 f (instr:I.instruction)
450             end
451    
452    
453             fun frewriteDef _ = raise Fail ""
454             fun frewriteUse _ = raise Fail ""
455           end
456         structure SpillInstr = AMD64SpillInstr (
457                   structure I = I
458                   structure Props = AMD64InsnProps
459                   val floats16ByteAligned = true)
460         structure SpillHeur = ChaitinSpillHeur
461         structure Spill = RASpill (structure InsnProps = AMD64InsnProps
462                                    structure Asm = AMD64Asm)
463    
464         datatype spillOperandKind = SPILL_LOC | CONST_VAL
465         type spill_info = unit
466         fun beforeRA _ = ()
467    
468         val architecture = "amd64"
469         fun pure _ = true
470    
471         structure Int =
472            struct
473              val allRegs = C.Regs CellsBasis.GP {from=0, to=15, step=1}
474              val allRegsSet = List.foldl C.addReg C.empty allRegs
475              val dedicated = [C.rsp, C.rbp]
476              val avail = C.getReg (List.foldl C.rmvReg allRegsSet dedicated)
477              fun spillLoc _ = raise Fail ""
478              val mode = RACore.NO_OPTIMIZATION
479            end
480         structure Float =
481            struct
482              val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
483              val dedicated = []
484              fun spillLoc _ = raise Fail ""
485              val mode = Word.orb (RACore.HAS_PARALLEL_COPIES, RACore.DEAD_COPY_ELIM)
486            end
487    
488        )
489    
490    structure RA = RA2
491    structure Cells = AMD64Instr.C
492    structure T = AMD64MLTree
493    structure CFG = AMD64CFG
494    structure FlowGraph = AMD64FlowGraph
495    structure ChkTy = MLTreeCheckTy(structure T = T val intTy = 64)
496    structure Vararg = AMD64VarargCCallFn(
497                           structure T = T
498                           fun push e = T.EXT(AMD64InstrExt.PUSHQ e)
499                           val leave = T.EXT(AMD64InstrExt.LEAVE)
500                       )
501    
502    structure TestSA =
503      struct
504    
505        val wordTy = 64
506    
507        fun gen (functionName, stms, result) = let
508               val insnStrm = FlowGraph.build()
509               val stream as AMD64Stream.STREAM
510               { beginCluster,  (* start a cluster *)
511                 endCluster,    (* end a cluster *)
512                 emit,          (* emit MLTREE stm *)
513                 defineLabel,   (* define a local label *)
514                 entryLabel,    (* define an external entry *)
515                 exitBlock,     (* mark the end of a procedure *)
516                 pseudoOp,      (* emit a pseudo op *)
517                 annotation,    (* add an annotation *)
518                 ... } =
519                 AMD64.selectInstructions insnStrm
520            fun doit () = (
521                beginCluster 0;      (* start a new cluster *)
522                pseudoOp PseudoOpsBasisTyp.TEXT;
523                pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
524                entryLabel functionName; (* define the entry label *)
525                List.app emit stms; (* emit all the statements *)
526                exitBlock result;
527                endCluster [])
528            val cfg = doit ()
529            val cfg = RA.run cfg
530            val cfg = AMD64Expand.run cfg
531            in
532             (cfg, stream)        (* end the cluster *)
533           end
534    
535        fun codegen (functionName, target, proto, initStms, args) = let
536            val _ = Label.reset()
537    
538            val [functionName, target] = List.map Label.global [functionName, target]
539    
540            (* construct the C call *)
541            val {result, callseq} = CCalls.genCall {
542                       name=T.LABEL target,
543                       paramAlloc=fn _ => false,
544                       structRet=fn _ => T.REG (64, Cells.rax),
545                       saveRestoreDedicated=fn _ => {save=[], restore=[]},
546                       callComment=NONE,
547                       proto=proto,
548                       args=args}
549    
550            fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
551    
552            val stms = List.concat [
553                       [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
554                        T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
555                       initStms,
556                       callseq,
557                       [T.EXT(AMD64InstrExt.LEAVE)],
558                       [T.RET []]]
559            val _ = List.all (fn stm => ChkTy.check stm
560                                        orelse raise Fail ("typechecking error: "^AMD64MTC.AMD64MLTreeUtils.stmToString stm))
561                    stms
562            in
563               gen (functionName, stms, result)
564            end
565    
566        fun dumpOutput (cfg, stream) = let
567            val (cfg as Graph.GRAPH graph, blocks) =
568                    AMD64BlockPlacement.blockPlacement cfg
569            val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
570            in
571              AMD64Emit.asmEmit (cfg, blocks)
572            end (* dumpOutput *)
573    
574        fun lit i = T.LI (T.I.fromInt (wordTy, i))
575    
576       fun vararg _ = let
577               val _ = Label.reset()
578               val (lab, varargStms) = Vararg.genVarargs()
579               val asmOutStrm = TextIO.openOut "mlrisc.s"
580               fun doit () = dumpOutput(gen(lab, varargStms, [T.GPR (T.REG (wordTy, C.rax))]))
581               val _ = AsmStream.withStream asmOutStrm doit ()
582               val _ = TextIO.closeOut asmOutStrm
583               in
584                  0
585               end
586      end
587    
588    
589        (* machine-specific data *)
590        val wordTy = 64
591        val wordSzB = wordTy div 8
592        val param0 = T.REG(wordTy, Cells.rdi)
593    
594        (* maximum argument size in machine words *)
595        val maxArgSz = 16
596        val maxArgSzB = maxArgSz * wordSzB
597    (*
598    (* unit testing code *)
599    structure Test =
600      struct
601    
602        open CCalls
603    
604        fun li2k (_, k, _) = k
605    
606        val ty1 = CTy.C_STRUCT [CTy.C_STRUCT [CTy.C_unsigned CTy.I_char, CTy.C_unsigned CTy.I_int]]
607        val ty2 = CTy.C_STRUCT [CTy.C_signed CTy.I_short]
608        val ty3 = CTy.C_STRUCT [CTy.C_signed CTy.I_short, CTy.C_PTR]
609        val ty4 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR]
610        val ty4 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_unsigned CTy.I_int], CTy.C_PTR]
611        val ty5 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float]]
612        val ty6 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
613        val ty7 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_float],CTy.C_float,CTy.C_float]]
614        val ty8 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_unsigned CTy.I_int],CTy.C_float,CTy.C_float]]
615        val ty9 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
616        val ty10 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float, CTy.C_STRUCT[CTy.C_float,CTy.C_unsigned CTy.I_int]]]
617        val ty11 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_float, CTy.C_float, CTy.C_float]
618    
619        fun kindOfEB () = let
620            fun test (eb, k) = (kindOfEightByte eb = k) orelse raise Fail "failed test"
621            fun eb1 ty = hd (eightBytesOfCTy ty)
622            fun eb2 ty = hd(tl (eightBytesOfCTy ty))
623            in
624               List.all test [(eb1 ty1, K_GPR), (eb1 ty2, K_GPR), (eb2 ty3, K_GPR),
625                              (eb1 ty5, K_FPR), (eb1 ty6, K_FPR), (eb2 ty6, K_FPR),
626                              (eb1 ty7, K_FPR), (eb2 ty7, K_FPR),
627                              (eb1 ty8, K_GPR), (eb2 ty8, K_FPR)]
628            end
629    
630        fun slots () = let
631            fun test (lis : SA.slot list, ks2 : location_kind list) = let
632                val ks1 = List.map li2k lis
633                in
634                    (List.length ks1 = List.length ks2) andalso (ListPair.all (op =) (ks1, ks2))
635                end
636                val tests = [
637                           (ty2, [K_GPR]),
638                           (ty1, [K_GPR]),
639                           (ty3, [K_GPR, K_GPR]),
640                           (ty4, [K_GPR, K_GPR]),
641                           (ty5, [K_FPR]),
642                           (ty6, [K_FPR, K_FPR]),
643                           (ty7, [K_FPR, K_FPR]),
644                           (ty8, [K_GPR, K_FPR]),
645                           (ty11, [K_MEM, K_MEM, K_MEM])
646                                           ]
647                val (ts, anss) = ListPair.unzip tests
648                in
649                   ListPair.all test (List.map slotsOfCTy ts, anss) orelse raise Fail "failed test"
650                end
651      end
652    *)
653    
654    structure Test = struct end

Legend:
Removed from v.2993  
changed lines
  Added in v.3058

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