93d645a · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Identify tail calls while simplifying

93d645aEdwin Brady14 years ago

iif/testvm.iif+9−1

compare with master

unifiedsplit

@@ -6,6 +6,13 @@ fun plus(x, y) = case x of {

6 | S(k) => S (plus(k, y))

7 }

9+fun fact(x) = factAux(x, 1)

10+

11+fun factAux(x, acc) = case (x == 1) of {

12+ 0 => factAux(x-1, acc * x)

13+ | 1 => acc

14+ }

15+

9fun natToInt(x) = case x of {

16fun natToInt(x) = case x of {

10 O => 0

17 O => 0

11 | S(k) => let y = natToInt(k) in y + 1

18 | S(k) => let y = natToInt(k) in y + 1

@@ -16,4 +23,5 @@ fun intToNat(x) = case x of {

16 | _ => S (intToNat (x - 1))

23 | _ => S (intToNat (x - 1))

17 }

24 }

19−fun main() = printNum(natToInt(plus(S(S(O)), intToNat(2))))

26+fun main() = printNum(natToInt(plus(intToNat(fact(6)), S(S(O)))))

27+

rts/idris_main.c+3

@@ -2,4 +2,7 @@ int main(int argc, char* argv[]) {

2 VM* vm = init_vm(1024000, 1024000);

4 _idris_main(vm, NULL);

5+#ifdef IDRIS_DEBUG

6+ printf("\nStack: %p %p\n", vm->valstack, vm->valstack_top);

7+#endif

src/IRTS/CodegenC.hs+4

@@ -81,6 +81,10 @@ bcc i (OP l fn args) = indent i ++ creg l ++ " = " ++ doOp fn args ++ ";\n"

82doOp LPlus [l, r] = "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

83doOp LMinus [l, r] = "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

84+doOp LTimes [l, r] = "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"

85+doOp LDiv [l, r] = "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

86+doOp LEq [l, r] = "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

84doOp LPrintNum [x] = "NULL; printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

87doOp LPrintNum [x] = "NULL; printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

88+doOp LPrintStr [x] = "NULL; printf(GETSTR(" ++ creg x ++ "))"

85doOp _ _ = "FAIL"

89doOp _ _ = "FAIL"

src/IRTS/LParser.hs+1

@@ -56,6 +56,7 @@ fovm f = do defs <- parseFOVM f

56 let h = concatMap toDecl (map fst bc)

57 let cc = concatMap (uncurry toC) bc

58 putStrLn "#include <idris_rts.h>\n"

59+ putStrLn "#define IDRIS_DEBUG\n"

59 putStrLn h

60 putStrLn h

60 putStrLn cc

61 putStrLn cc

61 d <- getDataDir

62 d <- getDataDir

src/IRTS/Simplified.hs+27−27

@@ -34,29 +34,29 @@ ldefs :: State (LDefs, Int) LDefs

34ldefs = do (l, h) <- get

35 return l

37−simplify :: LExp -> State (LDefs, Int) SExp

37+simplify :: Bool -> LExp -> State (LDefs, Int) SExp

38−simplify (LV (Loc i)) = return (SV (Loc i))

38+simplify tl (LV (Loc i)) = return (SV (Loc i))

39−simplify (LV (Glob x))

39+simplify tl (LV (Glob x))

40 = do ctxt <- ldefs

41 case lookupCtxt Nothing x ctxt of

42 [LConstructor _ t 0] -> return $ SCon t x []

43 _ -> return $ SV (Glob x)

44−simplify (LApp tc n args) = do args' <- mapM sVar args

44+simplify tl (LApp tc n args) = do args' <- mapM sVar args

45− mkapp (SApp tc n) args'

45+ mkapp (SApp (tl || tc) n) args'

46−simplify (LLet n v e) = do v' <- simplify v

46+simplify tl (LLet n v e) = do v' <- simplify False v

47− e' <- simplify e

47+ e' <- simplify tl e

48− return (SLet (Glob n) v' e')

48+ return (SLet (Glob n) v' e')

49−simplify (LCon i n args) = do args' <- mapM sVar args

49+simplify tl (LCon i n args) = do args' <- mapM sVar args

50− mkapp (SCon i n) args'

50+ mkapp (SCon i n) args'

51−simplify (LCase e alts) = do v <- sVar e

51+simplify tl (LCase e alts) = do v <- sVar e

52− alts' <- mapM sAlt alts

52+ alts' <- mapM (sAlt tl) alts

53− case v of

53+ case v of

54− (x, Nothing) -> return (SCase x alts')

54+ (x, Nothing) -> return (SCase x alts')

55− (Glob x, Just e) ->

55+ (Glob x, Just e) ->

56− return (SLet (Glob x) e (SCase (Glob x) alts'))

56+ return (SLet (Glob x) e (SCase (Glob x) alts'))

57−simplify (LConst c) = return (SConst c)

57+simplify tl (LConst c) = return (SConst c)

58−simplify (LOp p args) = do args' <- mapM sVar args

58+simplify tl (LOp p args) = do args' <- mapM sVar args

59− mkapp (SOp p) args'

59+ mkapp (SOp p) args'

61sVar (LV (Glob x))

62 = do ctxt <- ldefs

@@ -64,7 +64,7 @@ sVar (LV (Glob x))

64 [LConstructor _ t 0] -> sVar (LCon t x [])

65 _ -> return (Glob x, Nothing)

66sVar (LV x) = return (x, Nothing)

67−sVar e = do e' <- simplify e

67+sVar e = do e' <- simplify False e

68 i <- hvar

69 return (Glob (MN i "R"), Just e')

@@ -75,12 +75,12 @@ mkapp f args = mkapp' f args [] where

75 = do sc <- mkapp' f xs (x : args)

76 return (SLet x e sc)

78−sAlt (LConCase i n args e) = do e' <- simplify e

78+sAlt tl (LConCase i n args e) = do e' <- simplify tl e

79− return (SConCase (-1) i n args e')

79+ return (SConCase (-1) i n args e')

80−sAlt (LConstCase c e) = do e' <- simplify e

80+sAlt tl (LConstCase c e) = do e' <- simplify tl e

81− return (SConstCase c e')

81+ return (SConstCase c e')

82−sAlt (LDefaultCase e) = do e' <- simplify e

82+sAlt tl (LDefaultCase e) = do e' <- simplify tl e

83− return (SDefaultCase e')

83+ return (SDefaultCase e')

85checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, SDecl)]

86checkDefs ctxt [] = return []

@@ -88,7 +88,7 @@ checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)

88 = do xs' <- checkDefs ctxt xs

89 return xs'

90checkDefs ctxt ((n, LFun n' args exp) : xs)

91− = do let sexp = evalState (simplify exp) (ctxt, 0)

91+ = do let sexp = evalState (simplify True exp) (ctxt, 0)

92 (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (-1)

93 xs' <- checkDefs ctxt xs

94 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')