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 3043, Thu May 29 01:53:59 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 38  Line 130 
130  end (* AMD64PseudoOps *)  end (* AMD64PseudoOps *)
131  *)  *)
132    
133    (*
134  functor AMD64PseudoOpsFn (  functor AMD64PseudoOpsFn (
135      structure T : MLTREE      structure T : MLTREE
136      structure MLTreeEval : MLTREE_EVAL where T = T      structure MLTreeEval : MLTREE_EVAL where T = T
137    ) : PSEUDO_OPS_BASIS = AMD64GasPseudoOps (    ) : PSEUDO_OPS_BASIS = AMD64GasPseudoOps (
138      structure T = T      structure T = T
139      structure MLTreeEval = MLTreeEval)      structure MLTreeEval = MLTreeEval)
140    *)
141    
 (*  
142  functor AMD64PseudoOpsFn (  functor AMD64PseudoOpsFn (
143      structure T : MLTREE      structure T : MLTREE
144      structure MLTreeEval : MLTREE_EVAL where T = T      structure MLTreeEval : MLTREE_EVAL where T = T
145    ) : PSEUDO_OPS_BASIS = AMD64DarwinPseudoOps (    ) : PSEUDO_OPS_BASIS = AMD64DarwinPseudoOps (
146      structure T = T      structure T = T
147      structure MLTreeEval = MLTreeEval)      structure MLTreeEval = MLTreeEval)
148  *)  
149    
150  structure AMD64PseudoOps = AMD64PseudoOpsFn(  structure AMD64PseudoOps = AMD64PseudoOpsFn(
151              structure T = AMD64MLTree              structure T = AMD64MLTree
# Line 234  Line 326 
326      structure CFG=AMD64CFG      structure CFG=AMD64CFG
327      structure Shuffle = AMD64Shuffle)      structure Shuffle = AMD64Shuffle)
328    
329    structure CCalls = AMD64SVIDFn (
330                        structure T = AMD64MLTree)
331    
332    (*
333  structure CCalls = AMD64SVID (  structure CCalls = AMD64SVID (
334             structure T = AMD64MLTree             structure T = AMD64MLTree
335             val frameAlign = 16)             val frameAlign = 16)
336    *)
337    
338  structure RA2 =  structure RA2 =
339      RISC_RA      RISC_RA
# Line 248  Line 344 
344       structure Rewrite =       structure Rewrite =
345         struct         struct
346           structure I = AMD64Instr           structure I = AMD64Instr
347           fun rewriteDef _ = raise Fail ""           structure C=I.C
348           fun rewriteUse _ = raise Fail ""           structure CB = CellsBasis
349             fun error msg = MLRiscErrorMsg.error("X86Rewrite", msg)
350    
351             fun operand (rs,rt) opnd =
352                 (case opnd
353                   of I.Direct (sz, r) => if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
354                    | I.Displace{base, disp, mem} =>
355                      if CB.sameColor(base,rs) then I.Displace{base=rt, disp=disp, mem=mem}
356                      else opnd
357                    | I.Indexed{base as SOME b, index, scale, disp, mem} => let
358                          val base'= if CB.sameColor(b,rs) then SOME rt else base
359                          val index'=if CB.sameColor(index,rs) then rt else index
360                      in I.Indexed{base=base', index=index', scale=scale, disp=disp, mem=mem}
361                      end
362                    | I.Indexed{base, index, scale, disp, mem=mem}  =>
363                      if CB.sameColor(index,rs) then
364                          I.Indexed{base=base, index=rt, scale=scale, disp=disp, mem=mem}
365                      else opnd
366                    | _ => opnd
367                  (*end case*))
368    
369    
370             fun rewriteDef (instr, rs, rt) = let
371                 fun operand(opnd as I.Direct (sz, r)) =
372                     if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
373                   | operand _ = error "operand: not I.Direct"
374                 fun replace r = if CB.sameColor(r,rs) then rt else r
375                 fun rewriteX86Def(instr) =
376                     (case instr
377                       of I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
378                          I.CALL{opnd=opnd, cutsTo=cutsTo,
379                                 return=CB.CellSet.map {from=rs,to=rt} return, pops=pops,
380                                 defs=CB.CellSet.map {from=rs,to=rt} defs, uses=uses, mem=mem}
381                        | I.MOVE{mvOp, src, dst} => I.MOVE{mvOp=mvOp, src=src, dst=operand dst}
382                        | I.LEAL{r32, addr} => I.LEAL{r32=replace r32, addr=addr}
383                        | I.LEAQ{r64, addr} => I.LEAQ{r64=replace r64, addr=addr}
384                        | I.BINARY{binOp, src, dst} =>
385                          I.BINARY{binOp=binOp, src=src, dst=operand dst}
386                        | I.SHIFT{shiftOp, src, dst, count} =>
387                          I.SHIFT{shiftOp=shiftOp, src=src, count=count, dst=operand dst}
388                        | I.UNARY{unOp, opnd} => I.UNARY{unOp=unOp, opnd=operand opnd}
389                        | I.SET{cond, opnd} => I.SET{cond=cond, opnd=operand opnd}
390                        | _ => instr
391                    (* end case *))
392    
393                 fun f (I.ANNOTATION{a,i}) =
394                     I.ANNOTATION{i=rewriteDef(i,rs,rt),
395                                  a=(case a of
396                                         CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
397                                         CB.DEF_USE{cellkind=CB.GP,uses=uses,
398                                                    defs=map replace defs}
399                                       | _ => a)}
400                   | f (I.INSTR i) = I.INSTR(rewriteX86Def(i))
401                   | f (I.COPY{k as CB.GP, sz, dst, src, tmp}) =
402                     I.COPY{k=k, sz=sz, dst=map replace dst, src=src, tmp=tmp}
403             in
404                 f(instr)
405             end
406    
407    
408             fun rewriteUse (instr, rs, rt) = let
409                 val operand = operand (rs, rt)
410                 fun replace r = if CB.sameColor(r,rs) then rt else r
411                 fun rewrite instr = (case instr
412                     of I.JMP(opnd, labs) => I.JMP(operand opnd, labs)
413                      | I.JCC{cond, opnd} => I.JCC{cond=cond, opnd = operand opnd}
414                      | I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
415                        I.CALL{opnd=operand opnd, defs=defs, return=return,
416                               uses=CB.CellSet.map {from=rs,to=rt} uses, cutsTo=cutsTo,
417                               mem=mem, pops=pops}
418                      | I.MOVE{mvOp, src, dst as I.Direct _} =>
419                        I.MOVE{mvOp=mvOp, src=operand src, dst=dst}
420                      | I.MOVE{mvOp, src, dst} =>
421                        I.MOVE{mvOp=mvOp, src=operand src, dst=operand dst}
422                      | I.LEAL{r32, addr} => I.LEAL{r32=r32, addr=operand addr}
423                      | I.LEAQ{r64, addr} => I.LEAQ{r64=r64, addr=operand addr}
424                      | I.CMPL{lsrc, rsrc} => I.CMPL{lsrc=operand lsrc, rsrc=operand rsrc}
425                      | I.CMPW{lsrc, rsrc} => I.CMPW{lsrc=operand lsrc, rsrc=operand rsrc}
426                      | I.CMPB{lsrc, rsrc} => I.CMPB{lsrc=operand lsrc, rsrc=operand rsrc}
427                      | I.TESTL{lsrc, rsrc} => I.TESTL{lsrc=operand lsrc, rsrc=operand rsrc}
428                      | I.TESTW{lsrc, rsrc} => I.TESTW{lsrc=operand lsrc, rsrc=operand rsrc}
429                      | I.TESTB{lsrc, rsrc} => I.TESTB{lsrc=operand lsrc, rsrc=operand rsrc}
430                      | I.BITOP{bitOp, lsrc, rsrc} =>
431                        I.BITOP{bitOp=bitOp, lsrc=operand lsrc, rsrc=operand rsrc}
432                      | I.BINARY{binOp, src, dst} =>
433                        I.BINARY{binOp=binOp, src=operand src, dst=operand dst}
434                      | I.SHIFT{shiftOp, src, dst, count} =>
435                        I.SHIFT{shiftOp=shiftOp, src=operand src, dst=operand dst,
436                                count=operand src}
437                    (* end case *))
438    
439                 fun f(I.ANNOTATION{a,i}) =
440                     I.ANNOTATION{i=rewriteUse(i, rs, rt),
441                                  a = case a of
442                                          CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
443                                          CB.DEF_USE{cellkind=CB.GP,uses=map replace uses,
444                                                     defs=defs}
445                                        | _ => a}
446                   | f(I.INSTR i) = I.INSTR(rewrite(i))
447                   | f(I.COPY{k as CB.GP, sz, dst, src, tmp}) =
448                     I.COPY{k=k, sz=sz, dst=dst, src=List.map replace src, tmp=tmp}
449             in
450                 f (instr:I.instruction)
451             end
452    
453    
454           fun frewriteDef _ = raise Fail ""           fun frewriteDef _ = raise Fail ""
455           fun frewriteUse _ = raise Fail ""           fun frewriteUse _ = raise Fail ""
456         end         end
# Line 263  Line 464 
464    
465       datatype spillOperandKind = SPILL_LOC | CONST_VAL       datatype spillOperandKind = SPILL_LOC | CONST_VAL
466       type spill_info = unit       type spill_info = unit
467       fun beforeRA _ = raise Fail ""       fun beforeRA _ = ()
468    
469       val architecture = "amd64"       val architecture = "amd64"
470       fun pure _ = true       fun pure _ = true
471    
472       structure Int =       structure Int =
473          struct          struct
474            val avail = []            val allRegs = C.Regs CellsBasis.GP {from=0, to=15, step=1}
475            val dedicated = []            val allRegsSet = List.foldl C.addReg C.empty allRegs
476              val dedicated = [C.rsp, C.rbp]
477              val avail = C.getReg (List.foldl C.rmvReg allRegsSet dedicated)
478            fun spillLoc _ = raise Fail ""            fun spillLoc _ = raise Fail ""
479            val mode = RACore.NO_OPTIMIZATION            val mode = RACore.NO_OPTIMIZATION
480          end          end
481       structure Float =       structure Float =
482          struct          struct
483            val avail = []            val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
484            val dedicated = []            val dedicated = []
485            fun spillLoc _ = raise Fail ""            fun spillLoc _ = raise Fail ""
486            val mode = RACore.NO_OPTIMIZATION            val mode = Word.orb (RACore.HAS_PARALLEL_COPIES, RACore.DEAD_COPY_ELIM)
487          end          end
488    
489      )      )
490    
491    structure RA = RA2
492    structure Cells = AMD64Instr.C
493    structure T = AMD64MLTree
494    structure CFG = AMD64CFG
495    structure FlowGraph = AMD64FlowGraph
496    structure ChkTy = MLTreeCheckTy(structure T = T val intTy = 64)
497    structure Vararg = AMD64VarargCCallFn(structure T = T)
498    
499    structure TestStagedAllocation =
500      struct
501    
502        val wordTy = 64
503    
504        fun gen (functionName, stms, result) = let
505               val insnStrm = FlowGraph.build()
506               val stream as AMD64Stream.STREAM
507               { beginCluster,  (* start a cluster *)
508                 endCluster,    (* end a cluster *)
509                 emit,          (* emit MLTREE stm *)
510                 defineLabel,   (* define a local label *)
511                 entryLabel,    (* define an external entry *)
512                 exitBlock,     (* mark the end of a procedure *)
513                 pseudoOp,      (* emit a pseudo op *)
514                 annotation,    (* add an annotation *)
515                 ... } =
516                 AMD64.selectInstructions insnStrm
517            fun doit () = (
518                beginCluster 0;      (* start a new cluster *)
519                pseudoOp PseudoOpsBasisTyp.TEXT;
520                pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
521                entryLabel functionName; (* define the entry label *)
522                List.app emit stms; (* emit all the statements *)
523                exitBlock result;
524                endCluster [])
525            val cfg = doit ()
526            val cfg = RA.run cfg
527            val cfg = AMD64Expand.run cfg
528            in
529             (cfg, stream)        (* end the cluster *)
530           end
531    
532        fun codegen (functionName, target, proto, initStms, args) = let
533            val _ = Label.reset()
534    
535            val [functionName, target] = List.map Label.global [functionName, target]
536    
537            (* construct the C call *)
538            val {result, callseq} = CCalls.genCall {
539                       name=T.LABEL target,
540                       paramAlloc=fn _ => false,
541                       structRet=fn _ => T.REG (64, Cells.rax),
542                       saveRestoreDedicated=fn _ => {save=[], restore=[]},
543                       callComment=NONE,
544                       proto=proto,
545                       args=args}
546    
547            fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
548    
549            val stms = List.concat [
550                       [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
551                        T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
552                       initStms,
553                       callseq,
554                       [T.EXT(AMD64InstrExt.LEAVE)],
555                       [T.RET []]]
556            val _ = List.all (fn stm => ChkTy.check stm
557                                        orelse raise Fail ("typechecking error: "^AMD64MTC.AMD64MLTreeUtils.stmToString stm))
558                    stms
559            in
560               gen (functionName, stms, result)
561            end
562    
563        fun dumpOutput (cfg, stream) = let
564            val (cfg as Graph.GRAPH graph, blocks) =
565                    AMD64BlockPlacement.blockPlacement cfg
566            val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
567            in
568              AMD64Emit.asmEmit (cfg, blocks)
569            end (* dumpOutput *)
570    
571        fun lit i = T.LI (T.I.fromInt (wordTy, i))
572    
573    (*
574       fun testVarargs _ = let
575               val lab = Label.global "varargs"
576               val tmp = C.newReg()
577               val tmpC = C.newReg()
578               val preCallInstrs = [T.MV(wordTy, C.rax, lit (List.length CCalls.CCs.fprParams))]
579               val stms =
580                   List.concat [
581                       [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
582                        T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
583                       [T.MV(wordTy, tmp, T.REG(wordTy, C.rsi))],
584                       [T.MV(wordTy, tmpC, T.REG(wordTy, C.rdi))],
585                       Vararg.genVarArgs (T.REG(wordTy, tmpC), tmp, preCallInstrs),
586                       [T.EXT(AMD64InstrExt.LEAVE)],
587                       [T.RET []]
588                       ]
589    
590               val asmOutStrm = TextIO.openOut "mlrisc.s"
591               fun doit () = dumpOutput(gen(lab, stms, [T.GPR (T.REG (wordTy, C.rax))]))
592               val _ = AsmStream.withStream asmOutStrm doit ()
593               val _ = TextIO.closeOut asmOutStrm
594               in
595                  0
596               end
597    *)
598      end
599    
600    
601        (* machine-specific data *)
602        val wordTy = 64
603        val wordSzB = wordTy div 8
604        val param0 = T.REG(wordTy, Cells.rdi)
605    
606        (* maximum argument size in machine words *)
607        val maxArgSz = 16
608        val maxArgSzB = maxArgSz * wordSzB
609    (*
610    (* unit testing code *)
611    structure Test =
612      struct
613    
614        open CCalls
615    
616        fun li2k (_, k, _) = k
617    
618        val ty1 = CTy.C_STRUCT [CTy.C_STRUCT [CTy.C_unsigned CTy.I_char, CTy.C_unsigned CTy.I_int]]
619        val ty2 = CTy.C_STRUCT [CTy.C_signed CTy.I_short]
620        val ty3 = CTy.C_STRUCT [CTy.C_signed CTy.I_short, CTy.C_PTR]
621        val ty4 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR]
622        val ty4 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_unsigned CTy.I_int], CTy.C_PTR]
623        val ty5 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float]]
624        val ty6 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
625        val ty7 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_float],CTy.C_float,CTy.C_float]]
626        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]]
627        val ty9 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
628        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]]]
629        val ty11 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_float, CTy.C_float, CTy.C_float]
630    
631        fun kindOfEB () = let
632            fun test (eb, k) = (kindOfEightByte eb = k) orelse raise Fail "failed test"
633            fun eb1 ty = hd (eightBytesOfCTy ty)
634            fun eb2 ty = hd(tl (eightBytesOfCTy ty))
635            in
636               List.all test [(eb1 ty1, K_GPR), (eb1 ty2, K_GPR), (eb2 ty3, K_GPR),
637                              (eb1 ty5, K_FPR), (eb1 ty6, K_FPR), (eb2 ty6, K_FPR),
638                              (eb1 ty7, K_FPR), (eb2 ty7, K_FPR),
639                              (eb1 ty8, K_GPR), (eb2 ty8, K_FPR)]
640            end
641    
642        fun slots () = let
643            fun test (lis : SA.slot list, ks2 : location_kind list) = let
644                val ks1 = List.map li2k lis
645                in
646                    (List.length ks1 = List.length ks2) andalso (ListPair.all (op =) (ks1, ks2))
647                end
648                val tests = [
649                           (ty2, [K_GPR]),
650                           (ty1, [K_GPR]),
651                           (ty3, [K_GPR, K_GPR]),
652                           (ty4, [K_GPR, K_GPR]),
653                           (ty5, [K_FPR]),
654                           (ty6, [K_FPR, K_FPR]),
655                           (ty7, [K_FPR, K_FPR]),
656                           (ty8, [K_GPR, K_FPR]),
657                           (ty11, [K_MEM, K_MEM, K_MEM])
658                                           ]
659                val (ts, anss) = ListPair.unzip tests
660                in
661                   ListPair.all test (List.map slotsOfCTy ts, anss) orelse raise Fail "failed test"
662                end
663      end
664    *)
665    
666    structure Test = struct end

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

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