From 8862f80efdff86b1aef77b2706ea0156bfd13b08 Mon Sep 17 00:00:00 2001 From: Peter Stephens Date: Sat, 4 Apr 2015 22:01:05 -0500 Subject: [PATCH] fsharp: step5: Added tail call optimization. --- Makefile | 1 + fsharp/Makefile | 4 ++-- fsharp/core.fs | 4 ++-- fsharp/env.fs | 16 +++++++------ fsharp/eval.fs | 34 ++++++++++++++++------------ fsharp/printer.fs | 2 +- fsharp/step5_tco.fs | 55 +++++++++++++++++++++++++++++++++++++++++++++ fsharp/types.fs | 13 ++++++----- 8 files changed, 98 insertions(+), 31 deletions(-) create mode 100644 fsharp/step5_tco.fs diff --git a/Makefile b/Makefile index f364bf20..d89659bd 100644 --- a/Makefile +++ b/Makefile @@ -30,6 +30,7 @@ EXCLUDE_TESTS += test^bash^step5 # no stack exhaustion or completion EXCLUDE_TESTS += test^c^step5 # segfault EXCLUDE_TESTS += test^cpp^step5 # completes at 10,000 EXCLUDE_TESTS += test^cs^step5 # fatal stack overflow fault +EXCLUDE_TESTS += test^fsharp^step5 # completes at 10,000, fatal stack overflow at 100,000 EXCLUDE_TESTS += test^haskell^step5 # test completes EXCLUDE_TESTS += test^make^step5 # no TCO capability/step EXCLUDE_TESTS += test^mal^step5 # no TCO capability/step diff --git a/fsharp/Makefile b/fsharp/Makefile index 9de75378..c49ccda0 100644 --- a/fsharp/Makefile +++ b/fsharp/Makefile @@ -14,9 +14,9 @@ TERMINAL_SOURCES = terminal.cs ##################### SRCS = step0_repl.fs step1_read_print.fs step2_eval.fs step3_env.fs \ - step4_if_fn_do.fs + step4_if_fn_do.fs step5_tco.fs -FSFLAGS = $(if $(strip $(DEBUG)),--debug+,) +FSFLAGS = $(if $(strip $(DEBUG)),--debug+,--debug- --optimize+ --tailcalls+) CSFLAGS = $(if $(strip $(DEBUG)),-debug+,) ##################### diff --git a/fsharp/core.fs b/fsharp/core.fs index 7054497d..607a1157 100644 --- a/fsharp/core.fs +++ b/fsharp/core.fs @@ -38,8 +38,8 @@ module Core | _ -> FALSE let count = function - | [List(a)] -> a |> List.fold (fun cnt _ -> cnt + 1L) 0L |> Number - | [Vector(v)] -> v.Length |> int64 |> Number + | [List(lst)] -> lst |> List.length |> int64 |> Number + | [Vector(vec)] -> vec |> Array.length |> int64 |> Number | [Nil] -> ZERO | [_] -> raise <| errArgMismatch () | _ -> raise <| errArity () diff --git a/fsharp/env.fs b/fsharp/env.fs index 6f300a85..790b8f29 100644 --- a/fsharp/env.fs +++ b/fsharp/env.fs @@ -2,9 +2,6 @@ module Env open Types - type Env = System.Collections.Generic.Dictionary - type EnvChain = Env list - let errSymbolNotFound s = EvalError(sprintf "'%s' not found" s) let errNoEnvironment () = EvalError("no environment") let errTooManyValues () = EvalError("too many values") @@ -37,13 +34,18 @@ module Env | Some(v) -> v | None -> raise <| errSymbolNotFound key - let makeFunc = + let private getNextValue = let counter = ref 0 - let getNext () = System.Threading.Interlocked.Increment(counter) - fun f -> Func(getNext (), f) + fun () -> System.Threading.Interlocked.Increment(counter) + + let makeBuiltInFunc f = + Func(getNextValue (), f, NIL, [], []) + + let makeFunc f body binds env = + Func(getNextValue (), f, body, binds, env) let makeRootEnv () = - let wrap name f = name, makeFunc f + let wrap name f = name, makeBuiltInFunc f let env = [ wrap "+" Core.add; wrap "-" Core.subtract; diff --git a/fsharp/eval.fs b/fsharp/eval.fs index 016aa433..a0ab0580 100644 --- a/fsharp/eval.fs +++ b/fsharp/eval.fs @@ -41,15 +41,15 @@ module Eval let form = eval env second Env.set env s form - and letStarForm env = function + and letStarForm outer = function | [bindings; form] -> - let newEnv = Env.makeNew env [] [] - let binder = setBinding newEnv + let inner = Env.makeNew outer [] [] + let binder = setBinding inner match bindings with | List(lst) -> lst |> iterPairs binder | Vector(vec) -> vec |> iterPairs binder | _ -> raise <| errExpected "list or vector" - eval newEnv form + inner, form | _ -> raise <| Core.errArity () and ifForm env = function @@ -59,11 +59,11 @@ module Eval and ifForm3 env condForm trueForm falseForm = match eval env condForm with - | Bool(false) | Nil -> eval env falseForm - | _ -> eval env trueForm + | Bool(false) | Nil -> falseForm + | _ -> trueForm and doForm env = function - | [a] -> eval env a + | [a] -> a | a::rest -> eval env a |> ignore doForm env rest @@ -71,9 +71,10 @@ module Eval and fnStarForm outer nodes = let makeFunc binds body = - Env.makeFunc (fun nodes -> - let inner = Env.makeNew outer binds nodes - eval inner body) + let f = fun nodes -> + let inner = Env.makeNew outer binds nodes + eval inner body + Env.makeFunc f body binds outer match nodes with | [List(binds); body] -> makeFunc binds body @@ -83,13 +84,18 @@ module Eval and eval env = function | List(Symbol("def!")::rest) -> defBangForm env rest - | List(Symbol("let*")::rest) -> letStarForm env rest - | List(Symbol("if")::rest) -> ifForm env rest - | List(Symbol("do")::rest) -> doForm env rest + | List(Symbol("let*")::rest) -> + let inner, form = letStarForm env rest + form |> eval inner + | List(Symbol("if")::rest) -> ifForm env rest |> eval env + | List(Symbol("do")::rest) -> doForm env rest |> eval env | List(Symbol("fn*")::rest) -> fnStarForm env rest | List(_) as node -> let resolved = node |> eval_ast env match resolved with - | List(Func(_, f)::rest) -> f rest + | List(Func(_, f, _, _, [])::rest) -> f rest + | List(Func(_, _, body, binds, outer)::rest) -> + let inner = Env.makeNew outer binds rest + body |> eval inner | _ -> raise <| errExpected "function" | node -> node |> eval_ast env diff --git a/fsharp/printer.fs b/fsharp/printer.fs index 6464a6fc..e055966a 100644 --- a/fsharp/printer.fs +++ b/fsharp/printer.fs @@ -23,7 +23,7 @@ module Printer | String(str) -> appendStr str | Bool(true) -> appendStr "true" | Bool(false) -> appendStr "false" - | Func(tag, _) -> pr_func tag + | Func(tag, _, _, _, _) -> pr_func tag and pr separator prefix node = appendStr prefix diff --git a/fsharp/step5_tco.fs b/fsharp/step5_tco.fs new file mode 100644 index 00000000..479c7b05 --- /dev/null +++ b/fsharp/step5_tco.fs @@ -0,0 +1,55 @@ +module REPL + open System + + let read input = + try + Reader.read_str input + with + | Types.ReaderError(msg) -> + printfn "%s" msg + [] + + let eval env ast = + try + Some(Eval.eval env ast) + with + | Types.EvalError(msg) -> + printfn "%s" msg + None + + let print v = + v + |> Seq.singleton + |> Printer.pr_str + |> printfn "%s" + + let re env input = + read input + |> Seq.ofList + |> Seq.choose (fun form -> eval env form) + + let rep env input = + input + |> re env + |> Seq.iter (fun value -> print value) + + let getReadlineMode (args : string array) = + if args.Length > 0 && args.[0] = "--raw" then + Readline.Mode.Raw + else + Readline.Mode.Terminal + + [] + let main args = + let mode = getReadlineMode args + let env = Env.makeRootEnv () + + re env "(def! not (fn* (a) (if a false true)))" |> Seq.iter ignore + + let rec loop () = + match Readline.read "user> " mode with + | null -> 0 + | input -> + rep env input + loop () + loop () diff --git a/fsharp/types.fs b/fsharp/types.fs index ed37416c..a83b03c4 100644 --- a/fsharp/types.fs +++ b/fsharp/types.fs @@ -14,7 +14,7 @@ module Types | Number of int64 | String of string | Bool of bool - | Func of int * (Node list -> Node) + | Func of int * (Node list -> Node) * Node * Node list * EnvChain static member private hashSeq (s : seq) = let iter st node = (st * 397) ^^^ node.GetHashCode() @@ -59,7 +59,7 @@ module Types | Number(_) -> 6 | String(_) -> 7 | Bool(_) -> 8 - | Func(_, _) -> 9 + | Func(_, _, _, _, _) -> 9 static member private equals x y = match x, y with @@ -74,7 +74,7 @@ module Types | Number(a), Number(b) -> a = b | String(a), String(b) -> a = b | Bool(a), Bool(b) -> a = b - | Func(a, _), Func(b, _) -> a = b + | Func(a, _, _, _, _), Func(b, _, _, _, _) -> a = b | _, _ -> false static member private compare x y = @@ -90,7 +90,7 @@ module Types | Number(a), Number(b) -> compare a b | String(a), String(b) -> compare a b | Bool(a), Bool(b) -> compare a b - | Func(a, _), Func(b, _) -> compare a b + | Func(a, _, _, _, _), Func(b, _, _, _, _) -> compare a b | a, b -> compare (Node.rank a) (Node.rank b) override x.Equals yobj = @@ -109,7 +109,7 @@ module Types | Number(num) -> hash num | String(str) -> hash str | Bool(b) -> hash b - | Func(tag, _) -> hash tag + | Func(tag, _, _, _, _) -> hash tag interface System.IComparable with member x.CompareTo yobj = @@ -117,6 +117,9 @@ module Types | :? Node as y -> Node.compare x y | _ -> invalidArg "yobj" "Cannot compare values of different types." + and Env = System.Collections.Generic.Dictionary + and EnvChain = Env list + let TRUE = Bool(true) let SomeTRUE = Some(TRUE) let FALSE = Bool(false) -- 2.20.1