Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] View of /branches/charisee/src/compiler/high-to-mid/shiftP.sml
ViewVC logotype

View of /branches/charisee/src/compiler/high-to-mid/shiftP.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2608 - (download) (annotate)
Fri May 2 18:04:54 2014 UTC (5 years, 4 months ago) by cchiw
File size: 3684 byte(s)
Quotient rule
(* Shift Functions cleans up Params, and shifts down indices*)
structure ShiftP = struct
    local
    structure E = Ein
    structure P=Printer

    in

fun insert (key, value) d =fn s =>
    if s = key then SOME value
    else d s

fun lookup k d = d k
val empty =fn key =>NONE

(*remap the tensor ids*)
fun cleanParams(body, params,args)=let
    (*First step build a list of occurances*)
    fun build(body,occur)=let 
        fun add([],dict)=dict
        | add(e1::es,dict)=let
            val dict'=build(e1, dict)
            in
                add(es, dict')
            end
        fun single(id,pos)=  let
            val d=insert(id, 1) occur
            in
                add (pos, d)
            end

        in (case body
            of E.Tensor(id,ix)  => insert(id, 1) occur
            | E.Sum(sx, e)      => build(e, occur)
            | E.Neg e           => build(e,occur)
            | E.Add e           => add (e, occur)
            | E.Sub(e1,e2)      => add([e1,e2],occur)
            | E.Div(e1,e2)      => add([e1,e2],occur)
            | E.Prod e          => add (e, occur)
            | E.Img(id,_,pos)   => single(id,pos)
            | E.Krn(id,_,pos)   => single(id,[pos])
            | E.Conv(id,_,h,_)  => let
                val d= insert(id, 1) occur
                    in insert(h, 1) d end
            | E.Const _         => occur
            | E.Field _         => occur
            | E.Delta _         => occur
            | E.Epsilon _       => occur
            | E.Value _         => occur
            | E.Partial _       => occur
            | E.Apply _         => occur
            | E.Lift _          => occur
            | E.Probe(e,x)      => raise Fail "Probe- Should have been expanded"
            (*end case*))
        end 
    
    val occur=build(body, empty)

    (*remove params, args that are not used *)
    fun removeP(_,_,newbie,lftp, [], lfta,_)=(newbie, lftp, lfta)
        | removeP(_,_,newbie,lftp, _, lfta,[])=(newbie, lftp, lfta)
        | removeP(pos,sumcount,newbie,lftp, p::pp, lfta,a::aa)=let
            val c=lookup pos occur 
            in case c
                of NONE  => removeP(pos+1, sumcount,newbie@[0], lftp, pp,lfta,aa)
                | SOME _ => removeP(pos+1,sumcount+1, newbie@[sumcount], lftp@[p], pp,lfta@[a],aa)
            end 
  
    val (newbie, params',args')=removeP(0,0,[],[],params,[],args)

    (*remap the tensor ids*)
    fun remap body=(case body
        of E.Tensor(id, ix)     => E.Tensor((List.nth( newbie,id)), ix)
        | E.Neg e               => E.Neg(remap e)
        | E.Sum(sx, e)          => E.Sum(sx, remap e)
        | E.Add e               => E.Add (List.map remap e)
        | E.Prod e              => E.Prod (List.map remap e)
        | E.Sub (e1,e2)         => E.Sub(remap e1, remap e2)
        | E.Div(e1,e2)          => E.Div(remap e1, remap e2)
        | E.Img(id,alpha,pos)   => E.Img((List.nth( newbie,id)),alpha,(List.map remap pos))
        | E.Krn(id,delta,pos)   => E.Krn((List.nth( newbie,id)),delta,(remap pos))
        | E.Conv(id,alpha,h,pos)=> let
            val id'=List.nth( newbie,id)
            val h'=List.nth( newbie,h)
            in E.Conv(id',alpha,h',pos) end
        | E.Const _         => body
        | E.Field _         => body
        | E.Delta _         => body
        | E.Epsilon _       => body
        | E.Value _         => body
        | E.Partial _       => body
        | E.Apply _         => body
        | E.Lift _          => body
        | E.Probe(e,x)      => raise Fail "Probe- Should have been expanded"
        (*end case*))

    val body'=remap body
    in
        (params',body',args')
    end

end (* local *)

end 

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