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 2995, Fri Apr 18 06:59:04 2008 UTC MLRISC/trunk/amd64/staged-allocation/test.sml revision 3038, Tue May 27 23:48:15 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 =
339        RISC_RA
340        (structure I = AMD64Instr
341         structure Asm = AMD64Asm
342         structure CFG = AMD64CFG
343         structure InsnProps = AMD64InsnProps
344         structure Rewrite =
345           struct
346             structure I = AMD64Instr
347             structure C=I.C
348             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 ""
455             fun frewriteUse _ = raise Fail ""
456           end
457         structure SpillInstr = AMD64SpillInstr (
458                   structure I = I
459                   structure Props = AMD64InsnProps
460                   val floats16ByteAligned = true)
461         structure SpillHeur = ChaitinSpillHeur
462         structure Spill = RASpill (structure InsnProps = AMD64InsnProps
463                                    structure Asm = AMD64Asm)
464    
465         datatype spillOperandKind = SPILL_LOC | CONST_VAL
466         type spill_info = unit
467         fun beforeRA _ = ()
468    
469         val architecture = "amd64"
470         fun pure _ = true
471    
472         structure Int =
473            struct
474              val avail = C.Regs CellsBasis.GP {from=0, to=15, step=1}
475              val dedicated = [C.rsp, C.rbp]
476              fun spillLoc _ = raise Fail ""
477              val mode = RACore.NO_OPTIMIZATION
478            end
479         structure Float =
480            struct
481              val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
482              val dedicated = []
483              fun spillLoc _ = raise Fail ""
484              val mode = Word.orb (RACore.HAS_PARALLEL_COPIES, RACore.DEAD_COPY_ELIM)
485            end
486    
487        )
488    
489    structure RA = RA2
490    structure Cells = AMD64Instr.C
491    structure T = AMD64MLTree
492    structure CFG = AMD64CFG
493    structure FlowGraph = AMD64FlowGraph
494    structure ChkTy = MLTreeCheckTy(structure T = T val intTy = 64)
495    
496    structure TestStagedAllocation =
497      struct
498    
499        val wordTy = 64
500    
501        fun codegen (functionName, target, proto, initStms, args) = let
502            val _ = Label.reset()
503    
504            val [functionName, target] = List.map Label.global [functionName, target]
505    
506            val insnStrm = FlowGraph.build()
507            (* construct the C call *)
508            val {result, callseq} = CCalls.genCall {
509                       name=T.LABEL target,
510                       paramAlloc=fn _ => false,
511                       structRet=fn _ => T.REG (64, Cells.rax),
512                       saveRestoreDedicated=fn _ => {save=[], restore=[]},
513                       callComment=NONE,
514                       proto=proto,
515                       args=args}
516    
517            fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
518    
519            val stms = List.concat [
520                       [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
521                        T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
522                       initStms,
523                       callseq,
524                       [T.EXT(AMD64InstrExt.LEAVE)],
525                       [T.RET []]]
526            val _ = List.all (fn stm => ChkTy.check stm
527                                        orelse raise Fail ("typechecking error: "^AMD64MTC.AMD64MLTreeUtils.stmToString stm))
528                    stms
529            val stream as AMD64Stream.STREAM
530               { beginCluster,  (* start a cluster *)
531                 endCluster,    (* end a cluster *)
532                 emit,          (* emit MLTREE stm *)
533                 defineLabel,   (* define a local label *)
534                 entryLabel,    (* define an external entry *)
535                 exitBlock,     (* mark the end of a procedure *)
536                 pseudoOp,      (* emit a pseudo op *)
537                 annotation,    (* add an annotation *)
538                 ... } =
539                 AMD64.selectInstructions insnStrm
540            fun doit () = (
541                beginCluster 0;      (* start a new cluster *)
542                pseudoOp PseudoOpsBasisTyp.TEXT;
543                pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
544                entryLabel functionName; (* define the entry label *)
545                List.app emit stms; (* emit all the statements *)
546                exitBlock result;
547                endCluster [])
548            val cfg = doit ()
549            val cfg = RA.run cfg
550            val cfg = AMD64Expand.run cfg
551            in
552             (cfg, stream)        (* end the cluster *)
553           end (* codegen *)
554    
555        fun dumpOutput (cfg, stream) = let
556            val (cfg as Graph.GRAPH graph, blocks) =
557                    AMD64BlockPlacement.blockPlacement cfg
558            val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
559            in
560              AMD64Emit.asmEmit (cfg, blocks)
561            end (* dumpOutput *)
562    
563      end
564    
565    
566        (* machine-specific data *)
567        val wordTy = 64
568        val wordSzB = wordTy div 8
569        val param0 = T.REG(wordTy, Cells.rdi)
570    
571        (* maximum argument size in machine words *)
572        val maxArgSz = 16
573        val maxArgSzB = maxArgSz * wordSzB
574    
575    (* unit testing code *)
576    structure Test =
577      struct
578    
579        open CCalls
580    
581        fun li2k (_, k, _) = k
582    
583        val ty1 = CTy.C_STRUCT [CTy.C_STRUCT [CTy.C_unsigned CTy.I_char, CTy.C_unsigned CTy.I_int]]
584        val ty2 = CTy.C_STRUCT [CTy.C_signed CTy.I_short]
585        val ty3 = CTy.C_STRUCT [CTy.C_signed CTy.I_short, CTy.C_PTR]
586        val ty4 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR]
587        val ty4 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_unsigned CTy.I_int], CTy.C_PTR]
588        val ty5 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float]]
589        val ty6 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
590        val ty7 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_float],CTy.C_float,CTy.C_float]]
591        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]]
592        val ty9 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
593        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]]]
594        val ty11 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_float, CTy.C_float, CTy.C_float]
595    
596        fun kindOfEB () = let
597            fun test (eb, k) = (kindOfEightByte eb = k) orelse raise Fail "failed test"
598            fun eb1 ty = hd (eightBytesOfCTy ty)
599            fun eb2 ty = hd(tl (eightBytesOfCTy ty))
600            in
601               List.all test [(eb1 ty1, K_GPR), (eb1 ty2, K_GPR), (eb2 ty3, K_GPR),
602                              (eb1 ty5, K_FPR), (eb1 ty6, K_FPR), (eb2 ty6, K_FPR),
603                              (eb1 ty7, K_FPR), (eb2 ty7, K_FPR),
604                              (eb1 ty8, K_GPR), (eb2 ty8, K_FPR)]
605            end
606    
607        fun slots () = let
608            fun test (lis : SA.slot list, ks2 : location_kind list) = let
609                val ks1 = List.map li2k lis
610                in
611                    (List.length ks1 = List.length ks2) andalso (ListPair.all (op =) (ks1, ks2))
612                end
613                val tests = [
614                           (ty2, [K_GPR]),
615                           (ty1, [K_GPR]),
616                           (ty3, [K_GPR, K_GPR]),
617                           (ty4, [K_GPR, K_GPR]),
618                           (ty5, [K_FPR]),
619                           (ty6, [K_FPR, K_FPR]),
620                           (ty7, [K_FPR, K_FPR]),
621                           (ty8, [K_GPR, K_FPR]),
622                           (ty11, [K_MEM, K_MEM, K_MEM])
623                                           ]
624                val (ts, anss) = ListPair.unzip tests
625                in
626                   ListPair.all test (List.map slotsOfCTy ts, anss) orelse raise Fail "failed test"
627                end
628      end

Legend:
Removed from v.2995  
changed lines
  Added in v.3038

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