("\\<\\(\\(data\\|abs\\|with\\|eq\\)?type\\)\\s-+\\('\\sw+\\s-+\\)*\\(\\sw+\\)"
(1 font-lock-keyword-face)
(4 font-lock-type-def-face))
- ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*="
+ ("\\<\\(val\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
(1 font-lock-keyword-face)
;;(6 font-lock-variable-def-face nil t)
(3 font-lock-variable-name-face))
(let ((text
(save-excursion
(backward-char 2) ;back over the just inserted "| "
- (sml-find-matching-starter sml-pipehead-re
- (sml-op-prec "|" 'back))
- (let ((sym (sml-forward-sym)))
+ (let ((sym (sml-find-matching-starter sml-pipeheads
+ (sml-op-prec "|" 'back))))
+ (sml-forward-sym)
(sml-forward-spaces)
(cond
((string= sym "|")
(sml-forward-spaces))
(concat sym " = "))
((member sym '("case" "handle" "fn" "of")) " => ")
- ((member sym '("abstype" "datatype")) "")
- (t (error "Wow, now, there's a bug")))))))
+ ;;((member sym '("abstype" "datatype")) "")
+ (t ""))))))
(insert text)
(indent-according-to-mode)
(defun sml-indent-line ()
"Indent current line of ML code."
(interactive)
- (indent-line-to (sml-calculate-indentation)))
+ (let ((savep (> (current-column) (current-indentation)))
+ (indent (or (ignore-errors (sml-calculate-indentation)) 0)))
+ (if savep
+ (save-excursion (indent-line-to indent))
+ (indent-line-to indent))))
(defun sml-back-to-outer-indent ()
"Unindents to the next outer level of indentation."
(and (setq data (assoc sym sml-close-paren))
(sml-indent-relative sym data))
- (and (looking-at sml-starters-re)
+ (and (member (save-excursion (sml-forward-sym)) sml-starters-syms)
(let ((sym (unless (save-excursion (sml-backward-arg))
(sml-backward-spaces)
(sml-backward-sym))))
(if sym (sml-get-sym-indent sym)
;; FIXME: this can take a *long* time !!
- (sml-find-matching-starter sml-starters-re)
+ (sml-find-matching-starter sml-starters-syms)
(current-column))))
(and (string= sym "|") (sml-indent-pipe))
(sml-delegated-indent))))
(defun sml-indent-pipe ()
- (when (sml-find-matching-starter sml-pipehead-re
- (sml-op-prec "|" 'back))
- (if (looking-at "|")
- (if (sml-bolp) (current-column) (sml-indent-pipe))
- (let ((pipe-indent (or (cdr (assoc "|" sml-symbol-indent)) -2)))
- (when (looking-at "\\(data\\|abs\\)type\\>")
- (re-search-forward "="))
- (sml-forward-sym)
- (sml-forward-spaces)
- (+ pipe-indent (current-column))))))
+ (let ((sym (sml-find-matching-starter sml-pipeheads
+ (sml-op-prec "|" 'back))))
+ (when sym
+ (if (string= sym "|")
+ (if (sml-bolp) (current-column) (sml-indent-pipe))
+ (let ((pipe-indent (or (cdr (assoc "|" sml-symbol-indent)) -2)))
+ (when (member sym '("datatype" "abstype"))
+ (re-search-forward "="))
+ (sml-forward-sym)
+ (sml-forward-spaces)
+ (+ pipe-indent (current-column)))))))
(defun sml-find-forward (re)
(sml-forward-spaces)
(if sym-indent
;; the previous sym is an indentation introducer: follow the rule
(let ((indent-after (or (cdr (assoc sym-after sml-symbol-indent)) 0)))
- (if noindent (current-column) (+ sym-indent indent-after)))
+ (if noindent
+ ;;(current-column)
+ sym-indent
+ (+ sym-indent indent-after)))
;; default-default
(let* ((prec-after (sml-op-prec sym-after 'back))
(prec (or (sml-op-prec sym-before 'back) prec-after 100)))
(when noindent
(sml-move-if
(sml-backward-spaces)
- (string-match sml-starters-re (or (sml-backward-sym) ""))))
+ (member (sml-backward-sym) sml-starters-syms)))
(current-column)))))
(current-column)))
-(defun sml-find-matching-starter (regexp &optional prec)
- (ignore-errors
- (sml-backward-sexp prec)
- (while (not (or (looking-at regexp) (bobp)))
- (sml-backward-sexp prec))
- (not (bobp))))
+(defun sml-find-matching-starter (syms &optional prec)
+ (let (sym)
+ (ignore-errors
+ (while
+ (progn (sml-backward-sexp prec)
+ (setq sym (save-excursion (sml-forward-sym)))
+ (not (or (member sym syms) (bobp)))))
+ (unless (bobp) sym))))
(defun sml-comment-indent ()
(if (looking-at "^(\\*") ; Existing comment at beginning
--- /dev/null
+(* copyright 1999 YALE FLINT project *)
+(* monnier@cs.yale.edu *)
+
+let datatype foobar
+ = FooB of int
+ | FooA of bool * int
+
+ val x = if foo then
+ 1
+ else if bar then
+ 2
+ else
+ 3
+ val y = if foo
+ then 1
+ else if foo
+ then 2
+ else 3
+in
+ if a then b else c;
+ case M.find(m,f)
+ of SOME(fl, filt) =>
+ F.APP(F.VAR fl, OU.filter filt vs)
+ | NONE => le;
+ x := x + 1;
+ (case foo
+ of a => f
+ )
+end
+
+let
+in a;
+ b
+end
+
+let
+in if a then
+ b
+ else
+ c
+end
+
+let
+in case a of
+ (* Do I really want that ? *)
+ F => 1
+ | D => 2
+end
+
+let
+in if a then b else
+ c
+end
+
+structure Foo = struct
+val x = 1
+end
+
+signature FSPLIT =
+sig
+ type flint = FLINT.prog
+ val split: flint -> flint * flint option
+end
+
+structure FSplit :> FSPLIT =
+struct
+
+local
+ structure F = FLINT
+ structure S = IntRedBlackSet
+ structure M = FLINTIntMap
+ structure O = Option
+ structure OU = OptUtils
+ structure FU = FlintUtil
+ structure LT = LtyExtern
+ structure PO = PrimOp
+ structure PP = PPFlint
+ structure CTRL = FLINT_Control
+in
+
+val say = Control_Print.say
+fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
+fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
+fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
+fun assert p = if p then () else bug ("assertion failed")
+
+type flint = F.prog
+val mklv = LambdaVar.mkLvar
+val cplv = LambdaVar.dupLvar
+
+fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
+
+fun addv (s,F.VAR lv) = S.add(s, lv)
+ | addv (s,_) = s
+fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
+fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv(l, s)) s lvs
+
+exception Unknown
+
+fun split (fdec as (fk,f,args,body)) = let
+ val {getLty,addLty,...} = Recover.recover (fdec, false)
+
+ val m = Intmap.new(64, Unknown)
+ fun addpurefun f = Intmap.add m (f, false)
+ fun funeffect f = (Intmap.map m f) handle Uknown => true
+
+(* sexp: env -> lexp -> (leE, leI, fvI, leRet)
+ * - env: IntSetF.set current environment
+ * - lexp: lexp expression to split
+ * - leRet: lexp the core return expression of lexp
+ * - leE: lexp -> lexp recursively split lexp: leE leRet == lexp
+ * - leI: lexp option inlinable part of lexp (if any)
+ * - fvI: IntSetF.set free variables of leI: FU.freevars leI == fvI
+ *
+ * sexp splits the lexp into an expansive part and an inlinable part.
+ * The inlinable part is guaranteed to be side-effect free.
+ * The expansive part doesn't bother to eliminate unused copies of
+ * elements copied to the inlinable part.
+ * If the inlinable part cannot be constructed, leI is set to F.RET[].
+ * This implies that fvI == S.empty, which in turn prevents us from
+ * mistakenly adding anything to leI.
+ *)
+fun sexp env lexp = (* fixindent *)
+ let
+ (* non-side effecting binds are copied to leI if exported *)
+ fun let1 (le,lewrap,lv,vs,effect) =
+ let val (leE,leI,fvI,leRet) = sexp (S.add(env, lv)) le
+ val leE = lewrap o leE
+ in if effect orelse not (S.member(fvI, lv))
+ then (leE, leI, fvI, leRet)
+ else (leE, lewrap leI, addvs(S_rmv(lv, fvI), vs), leRet)
+ end
+
+ in case lexp
+ (* we can completely move both RET and TAPP to the I part *)
+ of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
+ if lv' = lv
+ then (fn e => e, lexp, addvs(S.empty, vs), lexp)
+ else (fn e => e, le, S.singleton lv', le)
+ | F.RET vs =>
+ (fn e => e, lexp, addvs(S.empty, vs), lexp)
+ | F.TAPP (F.VAR tf,tycs) =>
+ (fn e => e, lexp, S.singleton tf, lexp)
+
+ (* recursive splittable lexps *)
+ | F.FIX (fdecs,le) => sfix env (fdecs, le)
+ | F.TFN (tfdec,le) => stfn env (tfdec, le)
+
+ (* binding-lexps *)
+ | F.CON (dc,tycs,v,lv,le) =>
+ let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
+ | F.RECORD (rk,vs,lv,le) =>
+ let1(le, fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
+ | F.SELECT (v,i,lv,le) =>
+ let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
+ | F.PRIMOP (po,vs,lv,le) =>
+ let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
+
+ (* IMPROVEME: lvs should not be restricted to [lv] *)
+ | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
+ let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
+ | F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
+ let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
+
+ | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
+ let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
+
+ | F.LET (lvs,body,le) =>
+ let val (leE,leI,fvI,leRet) = sexp (S.union(S.addList(S.empty, lvs), env)) le
+ in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
+ end
+
+ (* useless sophistication *)
+ | F.APP (F.VAR f,args) =>
+ if funeffect f
+ then (fn e => e, F.RET[], S.empty, lexp)
+ else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
+
+ (* other non-binding lexps result in unsplittable functions *)
+ | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
+ | (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
+ (fn e => e, F.RET[], S.empty, lexp)
+ end
+
+(* Functions definitions fall into the following categories:
+ * - inlinable: if exported, copy to leI
+ * - (mutually) recursive: don't bother
+ * - non-inlinable non-recursive: split recursively *)
+and sfix env (fdecs,le) =
+ let val nenv = S.union(S.addList(S.empty, map #2 fdecs), env)
+ val (leE,leI,fvI,leRet) = sexp nenv le
+ val nleE = fn e => F.FIX(fdecs, leE e)
+ in case fdecs
+ of [({inline=inl as (F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
+ let val min = case inl of F.IH_MAYBE(n,_) => n | _ => 0
+ in if not(S.member(fvI, f)) orelse min > !CTRL.splitThreshold
+ then (nleE, leI, fvI, leRet)
+ else (nleE, F.FIX(fdecs, leI),
+ rmvs(S.union(fvI, FU.freevars body),
+ f::(map #1 args)),
+ leRet)
+ end
+ | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
+ sfdec env (leE,leI,fvI,leRet) fdec
+
+ | _ => (nleE, leI, fvI, leRet)
+ end
+
+and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
+ let val benv = S.union(S.addList(S.empty, map #1 args), env)
+ val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
+ in case bodyI
+ of F.RET[] =>
+ (fn e => F.FIX([(fk, f, args, bodyE bodyRet)], e),
+ leI, fvI, leRet)
+ | _ =>
+ let val fvbIs = S.listItems(S.difference(fvbI, benv))
+ val (nfk,fkE) = OU.fk_wrap(fk, NONE)
+
+ (* fdecE *)
+ val fE = cplv f
+ val fErets = (map F.VAR fvbIs)
+ val bodyE = bodyE(F.RET fErets)
+ (* val tmp = mklv()
+ val bodyE = bodyE(F.RECORD(F.RK_STRUCT, map F.VAR fvbIs,
+ tmp, F.RET[F.VAR tmp])) *)
+ val fdecE = (fkE, fE, args, bodyE)
+ val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
+ val _ = addLty(fE, fElty)
+
+ (* fdecI *)
+ val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
+ known=true, isrec=NONE}
+ val argsI =
+ (map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
+ (* val argI = mklv()
+ val argsI = (argI, LT.ltc_str(map (getLty o F.VAR) fvbIs))::args
+
+ val (_,bodyI) = foldl (fn (lv,(n,le)) =>
+ (n+1, F.SELECT(F.VAR argI, n, lv, le)))
+ (0, bodyI) fvbIs *)
+ val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
+ val _ = addpurefun fI
+
+ (* nfdec *)
+ val nargs = map (fn (v,t) => (cplv v, t)) args
+ val argsv = map (fn (v,t) => F.VAR v) nargs
+ val nbody =
+ let val lvs = map cplv fvbIs
+ in F.LET(lvs, F.APP(F.VAR fE, argsv),
+ F.APP(F.VAR fI, (map F.VAR lvs)@argsv))
+ end
+ (* let val lv = mklv()
+ in F.LET([lv], F.APP(F.VAR fE, argsv),
+ F.APP(F.VAR fI, (F.VAR lv)::argsv))
+ end *)
+ val nfdec = (nfk, f, nargs, nbody)
+
+ (* and now, for the whole F.FIX *)
+ fun nleE e =
+ F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
+
+ in if not(S.member(fvI, f)) then (nleE, leI, fvI, leRet)
+ else (nleE,
+ F.FIX([fdecI], F.FIX([nfdec], leI)),
+ S.add(S.union(S_rmv(f, fvI), S.intersection(env, fvbI)), fE),
+ leRet)
+ end
+ end
+
+(* TFNs are kinda like FIX except there's no recursion *)
+and stfn env (tfdec as (tfk,tf,args,body),le) =
+ let val (bodyE,bodyI,fvbI,bodyRet) =
+ if #inline tfk = F.IH_ALWAYS
+ then (fn e => body, body, FU.freevars body, body)
+ else sexp env body
+ val nenv = S.add(env, tf)
+ val (leE,leI,fvI,leRet) = sexp nenv le
+ in case (bodyI, S.listItems(S.difference(fvbI, env)))
+ of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
+ (* split failed *)
+ (fn e => F.TFN((tfk, tf, args, bodyE bodyRet), leE e),
+ leI, fvI, leRet)
+ | (_,[]) =>
+ (* everything was split out *)
+ let val ntfdec = ({inline=F.IH_ALWAYS}, tf, args, bodyE bodyRet)
+ val nlE = fn e => F.TFN(ntfdec, leE e)
+ in if not(S.member(fvI, tf)) then (nlE, leI, fvI, leRet)
+ else (nlE, F.TFN(ntfdec, leI),
+ S_rmv(tf, S.union(fvI, fvbI)), leRet)
+ end
+ | (_,fvbIs) =>
+ let (* tfdecE *)
+ val tfE = cplv tf
+ val tfEvs = map F.VAR fvbIs
+ val bodyE = bodyE(F.RET tfEvs)
+ val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
+ val _ = addLty(tfE, tfElty)
+
+ (* tfdecI *)
+ val tfkI = {inline=F.IH_ALWAYS}
+ val argsI = map (fn (v,k) => (cplv v, k)) args
+ val tmap = ListPair.map (fn (a1,a2) =>
+ (#1 a1, LT.tcc_nvar(#1 a2)))
+ (args, argsI)
+ val bodyI = FU.copy tmap M.empty
+ (F.LET(fvbIs, F.TAPP(F.VAR tfE, map #2 tmap),
+ bodyI))
+ (* F.TFN *)
+ fun nleE e =
+ F.TFN((tfk, tfE, args, bodyE),
+ F.TFN((tfkI, tf, argsI, bodyI), leE e))
+
+ in if not(S.member(fvI, tf)) then (nleE, leI, fvI, leRet)
+ else (nleE,
+ F.TFN((tfkI, tf, argsI, bodyI), leI),
+ S.add(S.union(S_rmv(tf, fvI), S.intersection(env, fvbI)), tfE),
+ leRet)
+ end
+ end
+
+(* here, we use B-decomposition, so the args should not be
+ * considered as being in scope *)
+val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
+in case (bodyI, bodyRet)
+ of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
+ | (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
+ let val fvbIs = S.listItems fvbI
+
+ (* fdecE *)
+ val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
+ val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
+
+ (* fdecI *)
+ val argI = mklv()
+ val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
+ val argsI = [(argI, LT.ltc_str argLtys)]
+ val (_,bodyI) = foldl (fn (lv,(n,le)) =>
+ (n+1, F.SELECT(F.VAR argI, n, lv, le)))
+ (length vs, bodyI) fvbIs
+ val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
+
+ val nargs = map (fn (v,t) => (cplv v, t)) args
+ in
+ (fdecE, SOME fdecI)
+ (* ((fk, f, nargs,
+ F.FIX([fdecE],
+ F.FIX([fdecI],
+ F.LET([argI],
+ F.APP(F.VAR fE, map (F.VAR o #1) nargs),
+ F.APP(F.VAR fI, [F.VAR argI]))))),
+ NONE) *)
+ end
+
+ | _ => (fdec, NONE) (* sorry, can't do that *)
+(* (PPFlint.printLexp bodyRet; bug "couldn't find the returned record") *)
+
+end
+
+end
+end