src/sml/sa.sml

   1 (* Semantic Analysis *)
   2
   3 signature SEMANTIC_ANALYSIS =
   4 sig
   5     val removeNestedDefine : Expr -> Expr;
   6     val boxSet : Expr -> Expr;
   7     val annotateTC : Expr -> Expr;
   8     val lexicalAddressing : Expr -> Expr;
   9     val semanticAnalysis : Expr -> Expr;
  10 end;
  11
  12 (* ******************************************************* Semantic Analysis *)
  13
  14 (* union any number of lists *)
  15 fun union [set, []] = set
  16   | union [set, (x :: rest)] =
  17         if not (List.exists (fn em => em=x) set) then
  18             union [(x :: set), rest]
  19         else
  20             union [set, rest]
  21   | union (A :: (B :: rest)) = union [A, union (B :: rest)]
  22   | union [A] = A
  23   | union [] = [];
  24
  25 (* intersect any number of lists *)
  26 fun intersect [set,[]] = []
  27   | intersect [set, (x :: rest)] =
  28         if List.exists (fn em => em=x) set then
  29             intersect [set,rest] @ [x]
  30         else
  31             intersect [set,rest]
  32   | intersect (A :: (B :: rest)) = intersect [A, intersect (B :: rest)]
  33   | intersect [A] = A
  34   | intersect [] = [];
  35
  36 (* (subtract A B) <==> A-B *)
  37 fun subtract set [] = set
  38   | subtract set (x :: rest) =
  39         subtract (List.filter (fn em => em<>x) set) rest;
  40
  41 (* (isMember e) S = true iff e is in S *)
  42 fun isMember e = List.exists (fn e' => e'=e);
  43
  44 exception ErrorEmptyBody;
  45 exception ErrorNotAVar;
  46 exception ErrorInvalidDefineContext;
  47
  48 structure SemanticAnalysis : SEMANTIC_ANALYSIS =
  49 struct
  50
  51 (* Keeps only first-level Seq objects, dissolves the inner ones *)
  52 fun flattenSeq(Seq [e]) = e
  53   | flattenSeq(Seq(cnt)) = Seq(dissolveSeq cnt)
  54   | flattenSeq(If(p,c,a)) = If(flattenSeq(p),flattenSeq(c),flattenSeq(a))
  55   | flattenSeq(Abs(p,b)) = Abs(p,flattenSeq(b))
  56   | flattenSeq(AbsOpt(p,opt,b)) = AbsOpt(p,opt,flattenSeq(b))
  57   | flattenSeq(AbsVar(opt,b)) = AbsVar(opt,flattenSeq(b))
  58   | flattenSeq(App(proc,params)) = App(flattenSeq(proc), map flattenSeq params)
  59   | flattenSeq(AppTP(proc,params)) = AppTP(flattenSeq(proc), map flattenSeq params)
  60   | flattenSeq(Or preds) = Or( map flattenSeq preds )
  61   | flattenSeq(Set(v,e)) = Set(v,flattenSeq(e))
  62   | flattenSeq(Def(v,e)) = Def(v,flattenSeq(e))
  63   | flattenSeq(x) = x
  64 (* Recursively replaces any Seq(x) with x *)
  65 and dissolveSeq(Seq(cnt) :: rest) = dissolveSeq(cnt) @ dissolveSeq(rest)
  66   | dissolveSeq(ex :: rest) = flattenSeq(ex) :: dissolveSeq(rest)
  67   | dissolveSeq([]) = [];
  68
  69 (* Keeps only top-level Define objects, and
  70    expands the inner ones to letrec.
  71    Inner Define objects must be first in the sequence of statements.
  72
  73    top-level Define objects: Define objects that affect the global enviroment
  74 *)
  75 fun removeNestedDefine'(e as Abs(_,Def(_,_))) = raise ErrorEmptyBody
  76   | removeNestedDefine'(e as AbsOpt(_,_,Def(_,_))) = raise ErrorEmptyBody
  77   | removeNestedDefine'(e as AbsVar(_,Def(_,_))) = raise ErrorEmptyBody
  78   | removeNestedDefine'(Abs(p,Seq (cnt as (Def(_,_) :: _)))) = Abs(p,expandDefines(cnt,[],[]))
  79   | removeNestedDefine'(AbsOpt(p,opt,Seq (cnt as (Def(_,_) :: _)))) = AbsOpt(p,opt,expandDefines(cnt,[],[]))
  80   | removeNestedDefine'(AbsVar(opt,Seq (cnt as (Def(_,_) :: _)))) = AbsVar(opt,expandDefines(cnt,[],[]))
  81   | removeNestedDefine'(Abs(p,b)) = Abs(p,removeNestedDefine'(b))
  82   | removeNestedDefine'(AbsOpt(p,opt,b)) = AbsOpt(p,opt,removeNestedDefine'(b))
  83   | removeNestedDefine'(AbsVar(opt,b)) = AbsVar(opt,removeNestedDefine'(b))
  84   | removeNestedDefine'(If(p,c,a)) = If(removeNestedDefine'(p),removeNestedDefine'(c),removeNestedDefine'(a))
  85   | removeNestedDefine'(App(proc,params)) = App(removeNestedDefine'(proc),map removeNestedDefine' params)
  86   | removeNestedDefine'(AppTP(proc,params)) = AppTP(removeNestedDefine'(proc),map removeNestedDefine' params)
  87   | removeNestedDefine'(Seq(cnt)) = Seq(map removeNestedDefine' cnt)
  88   | removeNestedDefine'(Or preds) = Or(map removeNestedDefine' preds)
  89   | removeNestedDefine'(Set(v,e)) = Set(v,removeNestedDefine'(e))
  90   | removeNestedDefine'(Def(v,e)) = Def(v,removeNestedDefine'(e))
  91   | removeNestedDefine'(x) = x
  92 and expandDefines([],_,_) = raise ErrorEmptyBody
  93   | expandDefines(Def(v,e) :: rest,vars,vals) = expandDefines(rest,v :: vars, e :: vals)
  94   | expandDefines(body,vars,vals) =
  95         makeLetRec(extractVarNames(List.rev(vars)),
  96                    List.rev(vals),
  97                    map removeNestedDefine' body)
  98 and makeLetRec(vars,vals,body) =
  99         App(Abs(vars,Seq(makeSetExprs(vars,vals) @ body)),map makeFalse vals)
 100 and makeSetExprs([],_) = []
 101   | makeSetExprs(_,[]) = []
 102   | makeSetExprs(v :: restVars, e :: restVals) = Set(Var(v),removeNestedDefine'(e)) :: makeSetExprs(restVars,restVals)
 103 and makeFalse(_) = Const(Bool false)
 104 and extractVarNames([]) = []
 105   | extractVarNames(Var(name) :: rest) = name :: extractVarNames(rest)
 106   | extractVarNames(_) = raise ErrorNotAVar
 107 and removeNestedDefine x = removeNestedDefine' (flattenSeq x);
 108
 109 (* Raises an error if there is a Define object with an invalid context (such as
 110    a Define inside an Abs) *)
 111 fun checkDefineContexts(If(p,c,a)) = If(checkDefineContexts(p),checkDefineContexts(c),checkDefineContexts(a))
 112   | checkDefineContexts(Abs(p,b)) = Abs(p,raiseErrorOnDefine(b))
 113   | checkDefineContexts(AbsOpt(p,opt,b)) = AbsOpt(p,opt,raiseErrorOnDefine(b))
 114   | checkDefineContexts(AbsVar(opt,b)) = AbsVar(opt,raiseErrorOnDefine(b))
 115   | checkDefineContexts(App(proc,params)) = App(checkDefineContexts(proc),map checkDefineContexts params)
 116   | checkDefineContexts(AppTP(proc,params)) = AppTP(checkDefineContexts(proc),map checkDefineContexts params)
 117   | checkDefineContexts(Seq cnt) = Seq( map checkDefineContexts cnt )
 118   | checkDefineContexts(Or preds) = Or( map checkDefineContexts preds )
 119   | checkDefineContexts(Set(v,e)) = Set(v,checkDefineContexts(e))
 120   | checkDefineContexts(Def(v,e)) = Def(v,checkDefineContexts(e))
 121   | checkDefineContexts(x) = x
 122 and raiseErrorOnDefine(Def(_,_)) = raise ErrorInvalidDefineContext
 123   | raiseErrorOnDefine(If(p,c,a)) = If(raiseErrorOnDefine(p),raiseErrorOnDefine(c),raiseErrorOnDefine(a))
 124   | raiseErrorOnDefine(Abs(p,b)) = Abs(p,raiseErrorOnDefine(b))
 125   | raiseErrorOnDefine(AbsOpt(p,opt,b)) = AbsOpt(p,opt,raiseErrorOnDefine(b))
 126   | raiseErrorOnDefine(AbsVar(opt,b)) = AbsVar(opt,raiseErrorOnDefine(b))
 127   | raiseErrorOnDefine(App(proc,params)) = App(raiseErrorOnDefine(proc),map raiseErrorOnDefine params)
 128   | raiseErrorOnDefine(AppTP(proc,params)) = AppTP(raiseErrorOnDefine(proc),map raiseErrorOnDefine params)
 129   | raiseErrorOnDefine(Seq cnt) = Seq( map raiseErrorOnDefine cnt )
 130   | raiseErrorOnDefine(Or preds) = Or( map raiseErrorOnDefine preds )
 131   | raiseErrorOnDefine(Set(v,e)) = Set(v,raiseErrorOnDefine(e))
 132   | raiseErrorOnDefine(x) = x;
 133
 134 (* Annotates tail applications.
 135    Takes an Expr as an argument and returns an Expr, in which all
 136    App-expressions that are in tail position have been replaced with
 137    corresponding AppTP-expressions.
 138 *)
 139 datatype Context = Head | Tail;
 140 fun annotateInContext context (If(test,dit,dif)) =
 141         If((annotateInContext Head test),(annotateInContext context dit),(annotateInContext context dif))
 142   | annotateInContext context (Seq []) = Seq []
 143   | annotateInContext context (Seq cnt) =
 144         let
 145             val last :: rest = List.rev cnt
 146             val annotatedLast = annotateInContext context last
 147             val annotatedRest = map (annotateInContext Head) rest
 148         in
 149             Seq(List.rev( annotatedLast :: annotatedRest ))
 150         end
 151   | annotateInContext context (Or []) = Or []
 152   | annotateInContext context (Or preds) =
 153         let
 154             val last :: rest = List.rev preds
 155             val annotatedLast = annotateInContext context last
 156             val annotatedRest = map (annotateInContext Head) rest
 157         in
 158             Or(List.rev( annotatedLast :: annotatedRest ))
 159         end
 160   | annotateInContext _ (Set(n,v)) = Set( (annotateInContext Head n), (annotateInContext Head v) )
 161   | annotateInContext _ (Def(n,v)) = Def( (annotateInContext Head n), (annotateInContext Head v) )
 162   | annotateInContext Head (App(proc,args)) = App( (annotateInContext Head proc), map (annotateInContext Head) args )
 163   | annotateInContext Tail (App(proc,args)) = AppTP( (annotateInContext Head proc), map (annotateInContext Head) args )
 164   | annotateInContext _ (Abs(p,b)) = Abs(p, annotateInContext Tail b)
 165   | annotateInContext _ (AbsOpt(p,opt,b)) = AbsOpt(p,opt,annotateInContext Tail b)
 166   | annotateInContext _ (AbsVar(opt,b)) = AbsVar(opt, annotateInContext Tail b)
 167   | annotateInContext _ x = x
 168 and annotateTC(x) = annotateInContext Tail x;
 169
 170 (* Autoboxing.
 171    Takes an Expr as an argument and returns an Expr, in which all variables that
 172    have both a bound occurrence and are set in a set!-expression are boxed.
 173    Boxing means
 174     * Copying the variable from the stack to the heap, right under the
 175       lambda-expression that deﬁnes the variable
 176     * Changing all get operations to unbox
 177     * Changing all set operations to box-set
 178 *)
 179 (* Returns the variables from V (arg1) that are set somewhere in arg2 *)
 180 fun filterSetVars V (Var n) = []
 181   | filterSetVars V (VarFree n) = filterSetVars V (Var n)
 182   | filterSetVars V (VarBound (n,_,_)) = filterSetVars V (Var n)
 183   | filterSetVars V (VarParam (n,_)) = filterSetVars V (Var n)
 184   | filterSetVars V (Const _) = []
 185   | filterSetVars V (If (test,dit,dif)) = union (map (filterSetVars V) [test,dit,dif])
 186   | filterSetVars V (Abs (P,b)) = filterSetVars (subtract V P) b
 187   | filterSetVars V (AbsOpt (P,opt,b)) = filterSetVars V (Abs (P @ [opt],b))
 188   | filterSetVars V (AbsVar (opt,b)) = filterSetVars V (Abs ([opt],b))
 189   | filterSetVars V (App (proc,args)) = union (map (filterSetVars V) (proc :: args))
 190   | filterSetVars V (AppTP (proc,args)) = filterSetVars V (App (proc,args))
 191   | filterSetVars V (Seq cnt) = union (map (filterSetVars V) cnt)
 192   | filterSetVars V (Or preds) = union (map (filterSetVars V) preds)
 193   | filterSetVars V (Set (Var n,e)) =
 194         if isMember n V then union [[n],filterSetVars V e]
 195                         else filterSetVars V e
 196   | filterSetVars V (Set (VarFree n,v)) = filterSetVars V (Set (Var n,v))
 197   | filterSetVars V (Set (VarBound (n,_,_),v)) = filterSetVars V (Set (Var n,v))
 198   | filterSetVars V (Set (VarParam (n,_),v)) = filterSetVars V (Set (Var n,v))
 199   | filterSetVars V (Set (n,v)) = union (map (filterSetVars V) [n,v])
 200   | filterSetVars V (Def (n,v)) = union (map (filterSetVars V) [n,v])
 201 (* Returns the free variables in arg2. arg1 is the list of already-bound vars *)
 202 and freeVarsIn' BV (Var n) = if isMember n BV then [] else [n]
 203   | freeVarsIn' BV (VarFree n) = freeVarsIn' BV (Var n)
 204   | freeVarsIn' BV (VarBound (n,_,_)) = freeVarsIn' BV (Var n)
 205   | freeVarsIn' BV (VarParam (n,_)) = freeVarsIn' BV (Var n)
 206   | freeVarsIn' BV (Const _) = []
 207   | freeVarsIn' BV (If (test,dit,dif)) = union (map (freeVarsIn' BV) [test,dit,dif])
 208   | freeVarsIn' BV (Abs (P,b)) = freeVarsIn' (union [BV,P]) b
 209   | freeVarsIn' BV (AbsOpt (P,opt,b)) = freeVarsIn' BV (Abs (P @ [opt],b))
 210   | freeVarsIn' BV (AbsVar (opt,b)) = freeVarsIn' BV (Abs ([opt],b))
 211   | freeVarsIn' BV (App (proc,args)) = union (map (freeVarsIn' BV) (proc :: args))
 212   | freeVarsIn' BV (AppTP (proc,args)) = freeVarsIn' BV (App (proc,args))
 213   | freeVarsIn' BV (Seq cnt) = union (map (freeVarsIn' BV) cnt)
 214   | freeVarsIn' BV (Or preds) = union (map (freeVarsIn' BV) preds)
 215   | freeVarsIn' BV (Set (n,v)) = union (map (freeVarsIn' BV) [n,v])
 216   | freeVarsIn' BV (Def (n,v)) = union (map (freeVarsIn' BV) [n,v])
 217 and freeVarsIn x = freeVarsIn' [] x
 218 (* Returns the vars of arg1 that have bound-occurrences in arg2.
 219    p has a bound-occurrence in b <==> p has a free-occurrence in an
 220    inner-lambda in b *)
 221 and filterBoundVars P (e as Abs (_,_)) = intersect [(freeVarsIn e),P]
 222   | filterBoundVars P (e as AbsOpt (_,_,_)) = intersect [(freeVarsIn e),P]
 223   | filterBoundVars P (e as AbsVar (_,_)) = intersect [(freeVarsIn e),P]
 224   | filterBoundVars P (If (test,dit,dif)) = union (map (filterBoundVars P) [test,dit,dif])
 225   | filterBoundVars P (App (proc,args)) = union (map (filterBoundVars P) (proc :: args))
 226   | filterBoundVars P (AppTP (proc,args)) = filterBoundVars P (App (proc,args))
 227   | filterBoundVars P (Seq cnt) = union (map (filterBoundVars P) cnt)
 228   | filterBoundVars P (Or cnt) = union (map (filterBoundVars P) cnt)
 229   | filterBoundVars P (Set (n,v)) = union (map (filterBoundVars P) [n,v])
 230   | filterBoundVars P (Def (n,v)) = union (map (filterBoundVars P) [n,v])
 231   | filterBoundVars _ _ = []
 232 (* Returns the vars from arg1 that need to be boxed in arg2 *)
 233 and filterParamsToBox P b = intersect [(filterBoundVars P b), (filterSetVars P b)]
 234 and makeBoxing name = Set (Var name,App (Var "box", [Var name]))
 235 and makeBoxRead name = App (Var "vector-ref", [Var name,Const (Number 0)])
 236 and makeBoxWrite name ex = App (Var "vector-set!", [Var name,Const (Number 0),ex])
 237 (* Traverses the expression arg2 and replaces
 238     Var x     with (vector-ref x 0)
 239     Set (x,v) with (vector-set! x 0 v)
 240    for each x in arg1 *)
 241 and boxAccesses [] x = x
 242   | boxAccesses V (Set (Var n,e)) =
 243         if isMember n V then makeBoxWrite n (boxAccesses V e)
 244                         else Set (Var n, boxAccesses V e)
 245   | boxAccesses V (Var n) =
 246         if isMember n V then makeBoxRead n
 247                         else Var n
 248   | boxAccesses V (Abs (P,b)) = Abs(P,boxAccesses (subtract V P) b)
 249   | boxAccesses V (AbsOpt (P,opt,b)) = AbsOpt(P,opt,boxAccesses (subtract V (opt :: P)) b)
 250   | boxAccesses V (AbsVar (opt,b)) = AbsVar(opt, boxAccesses (subtract V [opt]) b)
 251   | boxAccesses V (If (test,dit,dif)) = If (boxAccesses V test,boxAccesses V dit,boxAccesses V dif)
 252   | boxAccesses V (App (proc,args)) = App (boxAccesses V proc, map (boxAccesses V) args)
 253   | boxAccesses V (Seq cnt) = Seq (map (boxAccesses V) cnt)
 254   | boxAccesses V (Or preds) = Or (map (boxAccesses V) preds)
 255   | boxAccesses V (Set (v,e)) = Set (boxAccesses V v,boxAccesses V e)
 256   | boxAccesses V (Def (v,e)) = Def (boxAccesses V v,boxAccesses V e)
 257   | boxAccesses _ e = e
 258 and isAbs (Abs _) = true
 259   | isAbs (AbsOpt _) = true
 260   | isAbs (AbsVar _) = true
 261   | isAbs _ = false
 262 and boxSet (Abs (P,b)) =
 263         let
 264             val needBoxing = filterParamsToBox P b
 265             val boxingExprs = map makeBoxing needBoxing
 266             val fixedBody = boxAccesses needBoxing b
 267             val newBody = Seq (boxingExprs @ [fixedBody])
 268         in Abs (P,flattenSeq (boxSet newBody)) end
 269   | boxSet (AbsOpt (P,opt,b)) =
 270         let
 271             val needBoxing = filterParamsToBox (opt :: P) b
 272             val boxingExprs = map makeBoxing needBoxing
 273             val fixedBody = boxAccesses needBoxing b
 274             val newBody = Seq (boxingExprs @ [fixedBody])
 275         in AbsOpt (P,opt,flattenSeq (boxSet newBody)) end
 276   | boxSet (AbsVar (opt,b)) =
 277         let
 278             val needBoxing = filterParamsToBox [opt] b
 279             val boxingExprs = map makeBoxing needBoxing
 280             val fixedBody = boxAccesses needBoxing b
 281             val newBody = Seq (boxingExprs @ [fixedBody])
 282         in AbsVar (opt,flattenSeq (boxSet newBody)) end
 283   | boxSet (If (test,dit,dif)) = If (boxSet test,boxSet dit,boxSet dif)
 284   | boxSet (App (proc,args)) = App (boxSet proc,map boxSet args)
 285   | boxSet (AppTP (proc,args)) = AppTP (boxSet proc,map boxSet args)
 286   | boxSet (Seq cnt) = Seq (map boxSet cnt)
 287   | boxSet (Or preds) = Or (map boxSet preds)
 288   | boxSet (Set (n,v)) = Set (boxSet n,boxSet v)
 289   | boxSet (Def (n,v)) = Def (boxSet n,boxSet v)
 290   | boxSet x = x;
 291
 292 fun incMajors bounds = map (fn VarBound(name,major,minor) => VarBound(name,major+1,minor)) bounds
 293 and makeBoundVars params = map (fn VarParam(name,ndx) => VarBound(name,0,ndx)) params
 294 and makeParamVars [] _ = []
 295   | makeParamVars (name :: rest) ndx = VarParam(name,ndx) :: (makeParamVars rest (ndx+1))
 296 and lookupVar varname [] = VarFree(varname)
 297   | lookupVar varname (VarParam(name,ndx) :: rest) =
 298         if varname=name then VarParam(name,ndx)
 299         else lookupVar varname rest
 300   | lookupVar varname (VarBound(name,major,minor) :: rest) =
 301         if varname=name then VarBound(name,major,minor)
 302         else lookupVar varname rest
 303   | lookupVar varname (_ :: rest) = lookupVar varname rest
 304 and annotateVars bounds params (Abs(p,b)) =
 305         Abs(p, annotateVars ((makeBoundVars params) @ (incMajors bounds)) (makeParamVars p 0) b)
 306   | annotateVars bounds params (AbsOpt(p,opt,b)) =
 307         AbsOpt(p, opt, annotateVars ((makeBoundVars params) @ (incMajors bounds)) (makeParamVars (p @ [opt]) 0) b)
 308   | annotateVars bounds params (AbsVar(opt,b)) =
 309         AbsVar(opt, annotateVars ((makeBoundVars params) @ (incMajors bounds)) (makeParamVars [opt] 0) b)
 310   | annotateVars bounds params (If(test,dit,dif)) =
 311         If( (annotateVars bounds params test), (annotateVars bounds params dit), (annotateVars bounds params dif) )
 312   | annotateVars bounds params (App(proc,args))   = App( (annotateVars bounds params proc), map (annotateVars bounds params) args )
 313   | annotateVars bounds params (AppTP(proc,args)) = AppTP( (annotateVars bounds params proc), map (annotateVars bounds params) args )
 314   | annotateVars bounds params (Seq(cnt)) = Seq( map (annotateVars bounds params) cnt )
 315   | annotateVars bounds params (Or(preds)) = Or( map (annotateVars bounds params) preds )
 316   | annotateVars bounds params (Set(n,v)) = Set( (annotateVars bounds params n), (annotateVars bounds params v) )
 317   | annotateVars bounds params (Def(n,v)) = Def( (annotateVars bounds params n), (annotateVars bounds params v) )
 318   | annotateVars bounds params (Var(name)) = lookupVar name (params @ bounds)
 319   | annotateVars bounds params x = x
 320 and lexicalAddressing(x) = annotateVars [] [] x;
 321
 322 val semanticAnalysis =
 323     lexicalAddressing o
 324     annotateTC o
 325     boxSet o
 326 (*    checkDefineContexts o *)
 327     removeNestedDefine;
 328
 329 end; (* of struct SemanticAnalysis *)