168278e · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Hook up new output; deal with exact calls

168278eEdwin Brady14 years ago

src/Idris/AbsSyntax.hs+1

compare with master

unifiedsplit

@@ -415,6 +415,7 @@ data Opt = Filename String

415 | NoREPL

416 | OLogging Int

417 | Output String

418+ | NewOutput String

418 | TypeCase

419 | TypeCase

419 | TypeInType

420 | TypeInType

420 | NoCoverage

421 | NoCoverage

src/Main.hs+9

@@ -39,6 +39,7 @@ runIdris opts =

39 do let inputs = opt getFile opts

40 let runrepl = not (NoREPL `elem` opts)

41 let output = opt getOutput opts

42+ let newoutput = opt getNewOutput opts

42 let ibcsubdir = opt getIBCSubDir opts

43 let ibcsubdir = opt getIBCSubDir opts

43 let importdirs = opt getImportDir opts

44 let importdirs = opt getImportDir opts

44 let bcs = opt getBC opts

45 let bcs = opt getBC opts

@@ -69,6 +70,9 @@ runIdris opts =

69 when ok $ case output of

70 when ok $ case output of

70 [] -> return ()

71 [] -> return ()

71 (o:_) -> process "" (Compile o)

72 (o:_) -> process "" (Compile o)

73+ when ok $ case newoutput of

74+ [] -> return ()

75+ (o:_) -> process "" (NewCompile o)

72 when runrepl $ repl ist inputs

76 when runrepl $ repl ist inputs

73 ok <- noErrors

77 ok <- noErrors

74 when (not ok) $ liftIO (exitWith (ExitFailure 1))

78 when (not ok) $ liftIO (exitWith (ExitFailure 1))

@@ -92,6 +96,10 @@ getOutput :: Opt -> Maybe String

92getOutput (Output str) = Just str

96getOutput (Output str) = Just str

93getOutput _ = Nothing

97getOutput _ = Nothing

99+getNewOutput :: Opt -> Maybe String

100+getNewOutput (NewOutput str) = Just str

101+getNewOutput _ = Nothing

102+

95getIBCSubDir :: Opt -> Maybe String

103getIBCSubDir :: Opt -> Maybe String

96getIBCSubDir (IBCSubDir str) = Just str

104getIBCSubDir (IBCSubDir str) = Just str

97getIBCSubDir _ = Nothing

105getIBCSubDir _ = Nothing

@@ -123,6 +131,7 @@ parseArgs ("--log":lvl:ns) = liftM (OLogging (read lvl) : ) (parseArgs ns)

123parseArgs ("--noprelude":ns) = liftM (NoPrelude : ) (parseArgs ns)

131parseArgs ("--noprelude":ns) = liftM (NoPrelude : ) (parseArgs ns)

124parseArgs ("--check":ns) = liftM (NoREPL : ) (parseArgs ns)

132parseArgs ("--check":ns) = liftM (NoREPL : ) (parseArgs ns)

125parseArgs ("-o":n:ns) = liftM (\x -> NoREPL : Output n : x) (parseArgs ns)

133parseArgs ("-o":n:ns) = liftM (\x -> NoREPL : Output n : x) (parseArgs ns)

134+parseArgs ("-no":n:ns) = liftM (\x -> NoREPL : NewOutput n : x) (parseArgs ns)

126parseArgs ("--typecase":ns) = liftM (TypeCase : ) (parseArgs ns)

135parseArgs ("--typecase":ns) = liftM (TypeCase : ) (parseArgs ns)

127parseArgs ("--typeintype":ns) = liftM (TypeInType : ) (parseArgs ns)

136parseArgs ("--typeintype":ns) = liftM (TypeInType : ) (parseArgs ns)

128parseArgs ("--nocoverage":ns) = liftM (NoCoverage : ) (parseArgs ns)

137parseArgs ("--nocoverage":ns) = liftM (NoCoverage : ) (parseArgs ns)

src/RTS/CodegenC.hs+15−7

@@ -84,6 +84,9 @@ catom (CL l) = reg (LVar l)

84catom (CC (I i)) = "MKINT(" ++ show i ++ ")"

85catom (CC v) = "const(" ++ show v ++ ")"

86catom (CP n) = cname n

87+

88+off o (CL i) = CL (i + o)

89+off o x = x

88assignCon i r tag args

91assignCon i r tag args

89 = indent i ++ reg r ++ " = MKCON(" ++ show tag ++ ", " ++

92 = indent i ++ reg r ++ " = MKCON(" ++ show tag ++ ", " ++

@@ -97,17 +100,22 @@ assignCon i r tag args

100

98assignFn i r f args

101assignFn i r f args

99 = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++

102 = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++

100− indent i ++ setArgs 1 (reverse args) ++ "\n"

103+ indent i ++ setArgs 1 (map (off (length args)) (reverse args)) ++ "\n" ++

101− -- indent i ++ "CALL(" ++ reg r ++ ", " ++ cname f ++ ");\n"

104+ indent i ++ cname f ++ "(vm);\n" ++

105+ indent i ++ "CLEAR(" ++ show (length args) ++ ");\n" ++

106+ case r of

107+ RVal -> ""

108+ r -> indent i ++ reg r ++ " = " ++ reg RVal ++ "\n"

102 where

109 where

103 setArgs i [] = ""

110 setArgs i [] = ""

104 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "

111 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "

105 ++ setArgs (i + 1) as

112 ++ setArgs (i + 1) as

106

113

107−tailCall i d f args

114+doTailCall i d f args

108 = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++

115 = indent i ++ "EXTEND(" ++ show (length args) ++ ");\n" ++

109− indent i ++ setArgs 1 (reverse args) ++ "\n"

116+ indent i ++ setArgs 1 (map (off (length args)) (reverse args)) ++ "\n" ++

110−-- indent i ++ "TAILCALL(" ++ show d ++ ", " ++ cname f ++ ");\n"

117+ indent i ++ "SLIDE(" ++ show d ++ ", " ++ show (length args) ++ ");\n" ++

118+ indent i ++ cname f ++ "(vm); return;\n"

111 where

119 where

112 setArgs i [] = ""

120 setArgs i [] = ""

113 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "

121 setArgs i (a : as) = reg (LVar i) ++ " = " ++ catom a ++ "; "

@@ -116,7 +124,7 @@ tailCall i d f args

116cg :: Int -> CInst -> String

124cg :: Int -> CInst -> String

117cg i (ASSIGN r (CCon t args))

125cg i (ASSIGN r (CCon t args))

118 = assignCon i r t args

126 = assignCon i r t args

119−cg i (ASSIGN r (CApp f args))

127+cg i (ASSIGN r (CExactApp f args))

120 = assignFn i r f args

128 = assignFn i r f args

121cg i (ASSIGN r (CAtom e)) = indent i ++ reg r ++ " = " ++ catom e ++ ";\n"

129cg i (ASSIGN r (CAtom e)) = indent i ++ reg r ++ " = " ++ catom e ++ ";\n"

122cg i (RESERVE s) = indent i ++ "EXTEND(" ++ show s ++ ");\n"

130cg i (RESERVE s) = indent i ++ "EXTEND(" ++ show s ++ ");\n"

@@ -137,7 +145,7 @@ cg i (SWITCH v bs def)

137 branch (t, c) = indent i ++ "case " ++ show t ++ ":\n" ++

145 branch (t, c) = indent i ++ "case " ++ show t ++ ":\n" ++

138 concatMap (cg (i+1)) c ++

146 concatMap (cg (i+1)) c ++

139 indent (i+1) ++ "break;\n"

147 indent (i+1) ++ "break;\n"

140−cg i (TAILCALL d f args) = tailCall i d f args

148+cg i (TAILCALLEXACT d f args) = doTailCall i d f args

141cg i (ERROR s) = indent i ++ "ERROR(" ++ show s ++ ")\n";

149cg i (ERROR s) = indent i ++ "ERROR(" ++ show s ++ ")\n";

142cg i _ = indent i ++ "NOT DONE;\n"

150cg i _ = indent i ++ "NOT DONE;\n"

143

151

src/RTS/PreC.hs+6−5

@@ -14,7 +14,7 @@ data CAtom = CP Name | CL Local | CC Const

15data CExp = CAtom CAtom

16 | CApp CAtom [CAtom]

17− | CExactApp CAtom [CAtom]

17+ | CExactApp Name [CAtom]

18 | CLazy CAtom [CAtom]

19 | CFCall String CType [(CAtom, CType)]

20 | CPrimOp SPrim [CAtom]

@@ -38,7 +38,7 @@ data CInst = ASSIGN Reg CExp

38 | ERROR String

39 | TAILCALL Int -- number of stack items to clear

40 CAtom [CAtom]

41− | TAILCALLEXACT Int CAtom [CAtom]

41+ | TAILCALLEXACT Int Name [CAtom]

42 deriving Show

44type PreC = [CInst]

@@ -51,20 +51,21 @@ atom res (BL n) = CL (res - n)

51atom res (BC c) = CC c

53preC :: [(Name, (Int, Bytecode))] -> Bytecode -> (Int, PreC)

54−preC all (BGetArgs ns bc) = (length ns, pc RVal (length ns) bc)

54+preC all (BGetArgs ns bc) = (length ns, pc RVal (length ns) bc)

55 where arity n = do (i, b) <- lookup n all

56 return i

57 exact (BP n) as = case arity n of

58 Just i -> i == length as

59 Nothing -> False

60 exact _ as = False

61+ getName (BP n) = n

62 pc loc d (BAtom b) = [ASSIGN loc (CAtom (atom d b))]

63 pc loc d (BAtom b) = [ASSIGN loc (CAtom (atom d b))]

63 pc loc d (BApp f as)

64 pc loc d (BApp f as)

64− | exact f as = [ASSIGN loc (CExactApp (atom d f) (map (atom d) as))]

65+ | exact f as = [ASSIGN loc (CExactApp (getName f) (map (atom d) as))]

65 | otherwise = [ASSIGN loc (CApp (atom d f) (map (atom d) as))]

66 | otherwise = [ASSIGN loc (CApp (atom d f) (map (atom d) as))]

66 pc loc d (BTailApp f as)

67 pc loc d (BTailApp f as)

67− | exact f as = [TAILCALLEXACT d (atom d f) (map (atom d) as)]

68+ | exact f as = [TAILCALLEXACT d (getName f) (map (atom d) as)]

68 | otherwise = [TAILCALL d (atom d f) (map (atom d) as)]

69 | otherwise = [TAILCALL d (atom d f) (map (atom d) as)]

69 pc loc d (BLazy f as) = [ASSIGN loc (CLazy (atom d f) (map (atom d) as))]

70 pc loc d (BLazy f as) = [ASSIGN loc (CLazy (atom d f) (map (atom d) as))]

70 pc loc d (BLet x val sc) = pc (LVar (d - x)) d val ++ pc loc d sc

71 pc loc d (BLet x val sc) = pc (LVar (d - x)) d val ++ pc loc d sc

src/RTS/SC.hs+2

@@ -116,6 +116,8 @@ instance Lift Def () where

116 add (n, SCDef (zip (env ++ args) (repeat Nothing)) 0 cases')

117

118instance Lift (TT Name) SCExp where

119+ sc env (P (DCon t a) _ _) = return $ SCon t []

120+ sc env (P (TCon t a) _ _) = return $ SCon t []

119 sc env (P _ n _) = return $ SRef n

121 sc env (P _ n _) = return $ SRef n

120 sc env (V i) = return $ SRef (env!!i)

122 sc env (V i) = return $ SRef (env!!i)

121 sc env fn@(App _ _)

123 sc env fn@(App _ _)