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 3000, Tue Apr 22 08:01:00 2008 UTC MLRISC/trunk/amd64/staged-allocation/test.sml revision 3051, Fri May 30 06:29:06 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 234  Line 325 
325      structure CFG=AMD64CFG      structure CFG=AMD64CFG
326      structure Shuffle = AMD64Shuffle)      structure Shuffle = AMD64Shuffle)
327    
328    structure CCalls = AMD64SVIDFn (
329                        structure T = AMD64MLTree)
330    
331    (*
332  structure CCalls = AMD64SVID (  structure CCalls = AMD64SVID (
333             structure T = AMD64MLTree             structure T = AMD64MLTree
334             val frameAlign = 16)             val frameAlign = 16)
335    *)
336    
337  structure RA2 =  structure RA2 =
338      RISC_RA      RISC_RA
# Line 248  Line 343 
343       structure Rewrite =       structure Rewrite =
344         struct         struct
345           structure I = AMD64Instr           structure I = AMD64Instr
346           fun rewriteDef _ = raise Fail ""           structure C=I.C
347           fun rewriteUse _ = raise Fail ""           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 ""           fun frewriteDef _ = raise Fail ""
454           fun frewriteUse _ = raise Fail ""           fun frewriteUse _ = raise Fail ""
455         end         end
# Line 263  Line 463 
463    
464       datatype spillOperandKind = SPILL_LOC | CONST_VAL       datatype spillOperandKind = SPILL_LOC | CONST_VAL
465       type spill_info = unit       type spill_info = unit
466       fun beforeRA _ = raise Fail ""       fun beforeRA _ = ()
467    
468       val architecture = "amd64"       val architecture = "amd64"
469       fun pure _ = true       fun pure _ = true
470    
471       structure Int =       structure Int =
472          struct          struct
473            val avail = []            val allRegs = C.Regs CellsBasis.GP {from=0, to=15, step=1}
474            val dedicated = []            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 ""            fun spillLoc _ = raise Fail ""
478            val mode = RACore.NO_OPTIMIZATION            val mode = RACore.NO_OPTIMIZATION
479          end          end
480       structure Float =       structure Float =
481          struct          struct
482            val avail = []            val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
483            val dedicated = []            val dedicated = []
484            fun spillLoc _ = raise Fail ""            fun spillLoc _ = raise Fail ""
485            val mode = RACore.NO_OPTIMIZATION            val mode = Word.orb (RACore.HAS_PARALLEL_COPIES, RACore.DEAD_COPY_ELIM)
486          end          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(structure T = T)
497    
498    structure TestSA =
499      struct
500    
501        val wordTy = 64
502    
503        fun gen (functionName, stms, result) = let
504               val insnStrm = FlowGraph.build()
505               val stream as AMD64Stream.STREAM
506               { beginCluster,  (* start a cluster *)
507                 endCluster,    (* end a cluster *)
508                 emit,          (* emit MLTREE stm *)
509                 defineLabel,   (* define a local label *)
510                 entryLabel,    (* define an external entry *)
511                 exitBlock,     (* mark the end of a procedure *)
512                 pseudoOp,      (* emit a pseudo op *)
513                 annotation,    (* add an annotation *)
514                 ... } =
515                 AMD64.selectInstructions insnStrm
516            fun doit () = (
517                beginCluster 0;      (* start a new cluster *)
518                pseudoOp PseudoOpsBasisTyp.TEXT;
519                pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
520                entryLabel functionName; (* define the entry label *)
521                List.app emit stms; (* emit all the statements *)
522                exitBlock result;
523                endCluster [])
524            val cfg = doit ()
525            val cfg = RA.run cfg
526            val cfg = AMD64Expand.run cfg
527            in
528             (cfg, stream)        (* end the cluster *)
529           end
530    
531        fun codegen (functionName, target, proto, initStms, args) = let
532            val _ = Label.reset()
533    
534            val [functionName, target] = List.map Label.global [functionName, target]
535    
536            (* construct the C call *)
537            val {result, callseq} = CCalls.genCall {
538                       name=T.LABEL target,
539                       paramAlloc=fn _ => false,
540                       structRet=fn _ => T.REG (64, Cells.rax),
541                       saveRestoreDedicated=fn _ => {save=[], restore=[]},
542                       callComment=NONE,
543                       proto=proto,
544                       args=args}
545    
546            fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
547    
548            val stms = List.concat [
549                       [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
550                        T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
551                       initStms,
552                       callseq,
553                       [T.EXT(AMD64InstrExt.LEAVE)],
554                       [T.RET []]]
555            val _ = List.all (fn stm => ChkTy.check stm
556                                        orelse raise Fail ("typechecking error: "^AMD64MTC.AMD64MLTreeUtils.stmToString stm))
557                    stms
558            in
559               gen (functionName, stms, result)
560            end
561    
562        fun dumpOutput (cfg, stream) = let
563            val (cfg as Graph.GRAPH graph, blocks) =
564                    AMD64BlockPlacement.blockPlacement cfg
565            val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
566            in
567              AMD64Emit.asmEmit (cfg, blocks)
568            end (* dumpOutput *)
569    
570        fun lit i = T.LI (T.I.fromInt (wordTy, i))
571    
572       fun vararg _ = let
573               val lab = Label.global "varargs"
574               val tmp = C.newReg()
575               val tmpC = C.newReg()
576               val stms =
577                   List.concat [
578                       [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
579                        T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
580                       [T.MV(wordTy, tmp, T.REG(wordTy, C.rsi))],
581                       [T.MV(wordTy, tmpC, T.REG(wordTy, C.rdi))],
582                       Vararg.genVarargs (T.REG(wordTy, tmpC), tmp),
583                       [T.EXT(AMD64InstrExt.LEAVE)],
584                       [T.RET []]
585                       ]
586    
587               val asmOutStrm = TextIO.openOut "mlrisc.s"
588               fun doit () = dumpOutput(gen(lab, stms, [T.GPR (T.REG (wordTy, C.rax))]))
589               val _ = AsmStream.withStream asmOutStrm doit ()
590               val _ = TextIO.closeOut asmOutStrm
591               in
592                  0
593               end
594      end
595    
596    
597        (* machine-specific data *)
598        val wordTy = 64
599        val wordSzB = wordTy div 8
600        val param0 = T.REG(wordTy, Cells.rdi)
601    
602        (* maximum argument size in machine words *)
603        val maxArgSz = 16
604        val maxArgSzB = maxArgSz * wordSzB
605    (*
606    (* unit testing code *)
607    structure Test =
608      struct
609    
610        open CCalls
611    
612        fun li2k (_, k, _) = k
613    
614        val ty1 = CTy.C_STRUCT [CTy.C_STRUCT [CTy.C_unsigned CTy.I_char, CTy.C_unsigned CTy.I_int]]
615        val ty2 = CTy.C_STRUCT [CTy.C_signed CTy.I_short]
616        val ty3 = CTy.C_STRUCT [CTy.C_signed CTy.I_short, CTy.C_PTR]
617        val ty4 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR]
618        val ty4 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_unsigned CTy.I_int], CTy.C_PTR]
619        val ty5 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float]]
620        val ty6 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
621        val ty7 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_float],CTy.C_float,CTy.C_float]]
622        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]]
623        val ty9 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
624        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]]]
625        val ty11 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_float, CTy.C_float, CTy.C_float]
626    
627        fun kindOfEB () = let
628            fun test (eb, k) = (kindOfEightByte eb = k) orelse raise Fail "failed test"
629            fun eb1 ty = hd (eightBytesOfCTy ty)
630            fun eb2 ty = hd(tl (eightBytesOfCTy ty))
631            in
632               List.all test [(eb1 ty1, K_GPR), (eb1 ty2, K_GPR), (eb2 ty3, K_GPR),
633                              (eb1 ty5, K_FPR), (eb1 ty6, K_FPR), (eb2 ty6, K_FPR),
634                              (eb1 ty7, K_FPR), (eb2 ty7, K_FPR),
635                              (eb1 ty8, K_GPR), (eb2 ty8, K_FPR)]
636            end
637    
638        fun slots () = let
639            fun test (lis : SA.slot list, ks2 : location_kind list) = let
640                val ks1 = List.map li2k lis
641                in
642                    (List.length ks1 = List.length ks2) andalso (ListPair.all (op =) (ks1, ks2))
643                end
644                val tests = [
645                           (ty2, [K_GPR]),
646                           (ty1, [K_GPR]),
647                           (ty3, [K_GPR, K_GPR]),
648                           (ty4, [K_GPR, K_GPR]),
649                           (ty5, [K_FPR]),
650                           (ty6, [K_FPR, K_FPR]),
651                           (ty7, [K_FPR, K_FPR]),
652                           (ty8, [K_GPR, K_FPR]),
653                           (ty11, [K_MEM, K_MEM, K_MEM])
654                                           ]
655                val (ts, anss) = ListPair.unzip tests
656                in
657                   ListPair.all test (List.map slotsOfCTy ts, anss) orelse raise Fail "failed test"
658                end
659      end
660    *)
661    
662    structure Test = struct end

Legend:
Removed from v.3000  
changed lines
  Added in v.3051

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