11a8847 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Add PreC, for an imperative intermediate form that should be easy to generate code from

11a8847Edwin Brady14 years ago

idris.cabal+1−1

compare with master

unifiedsplit

@@ -68,7 +68,7 @@ Executable idris

69 Util.Pretty,

71− RTS.Bytecode, RTS.SC,

71+ RTS.Bytecode, RTS.SC, RTS.PreC,

73 Paths_idris

src/Idris/REPL.hs+9−2

@@ -22,6 +22,7 @@ import Core.Constraints

23import RTS.SC

24import RTS.Bytecode

25+import RTS.PreC

26import System.Console.Haskeline as H

27import System.Console.Haskeline as H

27import System.FilePath

28import System.FilePath

@@ -200,9 +201,15 @@ process fn (DebugInfo n)

200 when (not (null d)) $ liftIO $

201 when (not (null d)) $ liftIO $

201 do print (head d)

202 do print (head d)

202 let prims = idris_scprims i

203 let prims = idris_scprims i

204+ let scs = toSC prims (n, head d)

205+ let bcs = bcdefs scs

206+ let pcs = preCdefs bcs

207+ putStrLn "Supercombinators:\n"

203 print (toSC prims (n, head d))

208 print (toSC prims (n, head d))

204− putStrLn (showSep "\n"

209+ putStrLn "\nBytecode:\n"

205− (map show (bcdefs (toSC prims (n, head d)))))

210+ putStrLn (showSep "\n" (map show bcs))

211+ putStrLn "\nPre-C:\n"

212+ putStrLn (showSep "\n" (map show pcs))

206process fn (Info n) = do i <- get

213process fn (Info n) = do i <- get

207 case lookupCtxt Nothing n (idris_classes i) of

214 case lookupCtxt Nothing n (idris_classes i) of

208 [c] -> classInfo c

215 [c] -> classInfo c

src/RTS/Bytecode.hs+44−40

@@ -23,17 +23,16 @@ data Bytecode = BAtom BAtom

23 | BTailApp BAtom [BAtom]

24 | BLazy BAtom [BAtom]

25 | BLet Local Bytecode Bytecode

26− | BEval Local Bytecode

27 | BFCall String CType [(BAtom, CType)]

26 | BFCall String CType [(BAtom, CType)]

28 | BCon Tag [BAtom]

27 | BCon Tag [BAtom]

29 | BCase Local [BAlt]

28 | BCase Local [BAlt]

30 | BPrimOp SPrim [BAtom]

29 | BPrimOp SPrim [BAtom]

31 | BError String

30 | BError String

32− | GetArgs [Name] Bytecode -- get function arguments

31+ | BGetArgs [Name] Bytecode -- get function arguments

33− | Reserve Int Bytecode -- reserve stack space, clear on exit

32+ | BReserve Int Bytecode -- reserve stack space, clear on exit

34 deriving Show

33 deriving Show

36−data BAlt = BConCase Tag [Name] Bytecode

35+data BAlt = BConCase Tag [Name] Int Bytecode

37 | BConstCase Const Bytecode

36 | BConstCase Const Bytecode

38 | BDefaultCase Bytecode

37 | BDefaultCase Bytecode

39 deriving Show

38 deriving Show

@@ -41,12 +40,12 @@ data BAlt = BConCase Tag [Name] Bytecode

41bcdefs :: [(Name, SCDef)] -> [(Name, Bytecode)]

40bcdefs :: [(Name, SCDef)] -> [(Name, Bytecode)]

42bcdefs = map (\ (n, s) -> (n, bc s))

41bcdefs = map (\ (n, s) -> (n, bc s))

44−bc (SCDef args max c) = GetArgs (map fst args) (bcExp max (length args) c)

43+bc (SCDef args max c) = BGetArgs (map fst args) (bcExp max (length args) c)

46bcExp v arity x

45bcExp v arity x

47− = let (code, max) = runState (bc' True x) v

46+ = let (code, max) = runState (bc' True arity x) v

48 space = max - arity in

47 space = max - arity in

49− if (space > 0) then Reserve space code else code

48+ if (space > 0) then BReserve space code else code

50 where

49 where

51 ref i = do s <- get

50 ref i = do s <- get

52 when (i > s) $ put i

51 when (i > s) $ put i

@@ -54,34 +53,37 @@ bcExp v arity x

54 put (s + 1)

53 put (s + 1)

55 return s

54 return s

57− bc' :: Bool -> SCExp -> State Int Bytecode

56+ bc' :: Bool -> Int -> SCExp -> State Int Bytecode

58− bc' tl (SRef n) = return $ BAtom (BP n)

57+ bc' tl d (SRef n) = return $ BAtom (BP n)

59− bc' tl (SLoc i) = do ref i; return $ BAtom (BL i)

58+ bc' tl d (SLoc i) = do ref i; return $ BAtom (BL i)

60− bc' tl (SApp f args)

59+ bc' tl d (SApp f args)

61− = do f' <- bc' False f

60+ = do f' <- bc' False d f

62− args' <- mapM (bc' False) args

61+ args' <- mapM (bc' False d) args

63 let bapp = if tl then BTailApp else BApp

62 let bapp = if tl then BTailApp else BApp

64 case f' of

63 case f' of

65 BAtom r -> mkApp (\x -> bapp r x) args' []

64 BAtom r -> mkApp (\x -> bapp r x) args' []

66 bc -> do v <- next

65 bc -> do v <- next

67 mkApp (\x -> BLet v bc (bapp (BL v) x)) args' []

66 mkApp (\x -> BLet v bc (bapp (BL v) x)) args' []

68− bc' tl (SLazyApp f args) = do args' <- mapM (bc' False) args

67+ bc' tl d (SLazyApp f args) = do args' <- mapM (bc' False d) args

69− let bapp = if tl then BTailApp else BApp

68+ let bapp = if tl then BTailApp else BApp

70− mkApp (\x -> bapp (BP f) x) args' []

69+ mkApp (\x -> bapp (BP f) x) args' []

70+ bc' tl d (SLet n val sc) = do v' <- bc' False d val

71+ sc' <- bc' False (d + 1) sc

72+ return $ BLet d v' sc'

71− bc' tl (SCon t args) = do args' <- mapM (bc' False) args

73+ bc' tl d (SCon t args) = do args' <- mapM (bc' False d) args

72− mkApp (\x -> BCon t x) args' []

74+ mkApp (\x -> BCon t x) args' []

73− bc' tl (SFCall c t args) = do args' <- mapM (bc' False) (map fst args)

75+ bc' tl d (SFCall c t args) = do args' <- mapM (bc' False d) (map fst args)

74− mkFApp c t (zip args' (map snd args)) []

76+ mkFApp c t (zip args' (map snd args)) []

75− bc' tl (SConst c) = return $ BAtom (BC c)

77+ bc' tl d (SConst c) = return $ BAtom (BC c)

76− bc' tl (SError s) = return $ BError s

78+ bc' tl d (SError s) = return $ BError s

77− bc' tl (SCase e alts) = do e' <- bc' False e

79+ bc' tl d (SCase e alts) = do e' <- bc' False d e

78− alts' <- mapM (bcAlt tl) alts

80+ alts' <- mapM (bcAlt tl d) alts

79− case e' of

81+ case e' of

80− BAtom (BL i) -> return $ BCase i alts'

82+ BAtom (BL i) -> return $ BCase i alts'

81− bc -> do v <- next

83+ bc -> do v <- next

82− return $ BLet v bc (BCase v alts')

84+ return $ BLet v bc (BCase v alts')

83− bc' tl (SPrimOp p args) = do args' <- mapM (bc' tl) args

85+ bc' tl d (SPrimOp p args) = do args' <- mapM (bc' tl d) args

84− mkApp (\x -> BPrimOp p x) args' []

86+ mkApp (\x -> BPrimOp p x) args' []

86 mkApp ap [] locs = return $ ap locs

88 mkApp ap [] locs = return $ ap locs

87 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])

89 mkApp ap (BAtom (BL i) : as) locs = mkApp ap as (locs ++ [BL i])

@@ -89,16 +91,18 @@ bcExp v arity x

89 app <- mkApp ap as (locs ++ [BL v])

91 app <- mkApp ap as (locs ++ [BL v])

90 return $ BLet v a app

92 return $ BLet v a app

92− bcAlt tl (SConCase t args e) = do e' <- bc' tl e

94+ bcAlt tl d (SConCase t args e) = do e' <- bc' tl (d + length args) e

93− return $ BConCase t args e'

95+ return $ BConCase t args d e'

94− bcAlt tl (SConstCase i e) = do e' <- bc' tl e

96+ bcAlt tl d (SConstCase i e) = do e' <- bc' tl d e

95− return $ BConstCase i e'

97+ return $ BConstCase i e'

96− bcAlt tl (SDefaultCase e) = do e' <- bc' tl e

98+ bcAlt tl d (SDefaultCase e) = do e' <- bc' tl d e

97− return $ BDefaultCase e'

99+ return $ BDefaultCase e'

100

99 mkFApp c ty [] locs = return $ BFCall c ty locs

101 mkFApp c ty [] locs = return $ BFCall c ty locs

100− mkFApp c ty ((BAtom (BL i), t) : as) locs = mkFApp c ty as (locs ++ [(BL i, t)])

102+ mkFApp c ty ((BAtom (BL i), t) : as) locs

103+ = mkFApp c ty as (locs ++ [(BL i, t)])

101− mkFApp c ty ((a, t) : as) locs = do v <- next

104+ mkFApp c ty ((a, t) : as) locs

105+ = do v <- next

102− app <- mkFApp c ty as (locs ++ [(BL v, t)])

106+ app <- mkFApp c ty as (locs ++ [(BL v, t)])

103− return $ BLet v a app

107+ return $ BLet v a app

104

108

src/RTS/PreC.hsnew file+86

@@ -0,0 +1,86 @@

1+module RTS.PreC where

3+-- A representation close to the code we'll be outputting

5+import Core.TT

7+import RTS.Bytecode

8+import RTS.SC

10+import Control.Monad.State

11+

12+data CAtom = CP Name | CL Local | CC Const

13+ deriving Show

14+

15+data CExp = CAtom CAtom

16+ | CApp CAtom [CAtom]

17+ | CTailApp CAtom [CAtom]

18+ | CLazy CAtom [CAtom]

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

20+ | CPrimOp SPrim [CAtom]

21+ | CCon Tag [CAtom]

22+ deriving Show

23+

24+data CVal = CTag Local | CIntVal Local

25+ deriving Show

26+

27+-- Assignment is to the return value, or some local register

28+data Reg = RVal | LVar Local

29+ deriving Show

30+

31+data CInst = ASSIGN Reg CExp

32+ | RESERVE Int

33+ | EVAL Local

34+ | PROJECT Local Local Int

35+ | SWITCH CVal [(Int, PreC)] PreC

36+ | ERROR String

37+ | TAILCALL CAtom [CAtom]

38+ deriving Show

39+

40+type PreC = [CInst]

41+

42+preCdefs :: [(Name, Bytecode)] -> [(Name, (Int, PreC))]

43+preCdefs = map (\ (n, b) -> (n, preC b))

44+

45+atom (BP n) = CP n

46+atom (BL n) = CL n

47+atom (BC c) = CC c

48+

49+preC :: Bytecode -> (Int, PreC)

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

51+ where pc loc (BAtom b) = [ASSIGN loc (CAtom (atom b))]

52+ pc loc (BApp f as) = [ASSIGN loc (CApp (atom f) (map atom as))]

53+ pc loc (BTailApp f as) = [TAILCALL (atom f) (map atom as)]

54+ pc loc (BLazy f as) = [ASSIGN loc (CLazy (atom f) (map atom as))]

55+ pc loc (BLet x val sc) = pc (LVar x) val ++ pc loc sc

56+ pc loc (BFCall c t args)

57+ = [ASSIGN loc (CFCall c t (map (\ (a, ty) -> (atom a, ty)) args))]

58+ pc loc (BCon t args) = [ASSIGN loc (CCon t (map atom args))]

59+ pc loc (BPrimOp s args)

60+ = [ASSIGN loc (CPrimOp s (map atom args))]

61+ pc loc (BError s) = [ERROR s]

62+ pc loc (BCase l alts)

63+ = EVAL l :

64+ SWITCH (caseTy alts l) (map (pcAlt loc l) (filter notDef alts))

65+ (getDefault loc alts) : []

66+ pc loc (BReserve s bc) = RESERVE s : pc loc bc

67+

68+ notDef (BDefaultCase _) = False

69+ notDef _ = True

70+

71+ pcAlt loc var (BConCase t args l bc)

72+ = (t, PROJECT var l (length args) :

73+ pc loc bc)

74+ pcAlt loc var (BConstCase (I c) bc)

75+ = (c, pc loc bc)

76+

77+ getDefault loc (BDefaultCase bc : _) = pc loc bc

78+ getDefault loc (_ : xs) = getDefault loc xs

79+ getDefault loc [] = []

80+

81+ caseTy (BConCase _ _ _ _ : _) = CTag

82+ caseTy (BConstCase _ _ : _) = CIntVal

83+ caseTy (_ : xs) = caseTy xs

84+ caseTy [] = CTag

85+

86+