Skip to content
Browse files

Convert intermediate expressions to let bound variables

  • Loading branch information...
1 parent 9b1587b commit ece92fe82ad7672b63b5f5711302c2797dcd6cd5 @edwinb edwinb committed Aug 7, 2012
Showing with 200 additions and 83 deletions.
  1. +1 −1 idris.cabal
  2. +62 −14 src/IRTS/Bytecode.hs
  3. +7 −6 src/IRTS/LParser.hs
  4. +1 −62 src/IRTS/Lang.hs
  5. +129 −0 src/IRTS/Simplified.hs
View
2 idris.cabal
@@ -70,7 +70,7 @@ Executable idris
Util.Pretty,
RTS.Bytecode, RTS.SC, RTS.PreC, RTS.CodegenC,
- IRTS.Lang, IRTS.LParser, IRTS.Bytecode,
+ IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,
Paths_idris
View
76 src/IRTS/Bytecode.hs
@@ -1,21 +1,69 @@
module IRTS.Bytecode where
import IRTS.Lang
+import IRTS.Simplified
import Core.TT
+import Data.Maybe
-data BC = PUSH Int
- | PUSHCONST Const
- | MKCON Int Int
- | CASE [(Int, [BC])] (Maybe [BC])
- | CONSTCASE [(Const, [BC])] (Maybe [BC])
- | PRINTNUM
- | PRINTSTR
- | INTOP PrimFn
- deriving Show
+-- data Reg = RVal | CaseVar | L Int
-toBC :: (Name, LDecl) -> Maybe (Name, [BC])
-toBC (n, LConstructor _ _ _) = Nothing
-toBC (n, LFun n' args exp) = Just (n, bc exp)
+-- data BC = ASSIGN Reg Reg
+-- | ASSIGNCONST Reg Const
+-- | MKCON Reg Int Int
+-- | CASE [(Int, [BC])] (Maybe [BC])
+-- | GETARGS Int -- discards afterwards
+-- | CONSTCASE [(Const, [BC])] (Maybe [BC])
+-- | CALL Name
+-- | TAILCALL Name
+-- | PRINTNUM
+-- | PRINTSTR
+-- | GROWSTACK Int
+-- | DROPSTACK Int
+-- | SLIDE Int Int -- number to drop, number to keep
+-- | OP PrimFn
+-- deriving Show
-bc :: LExp -> [BC]
-bc x = []
+-- toBC :: (Name, LDecl) -> Maybe (Name, [BC])
+-- toBC (n, LConstructor _ _ _) = Nothing
+-- toBC (n, LFun n' args exp) = let cleanup = [SLIDE (length args) 1] in
+-- Just (n, bc (length args - 1) exp cleanup)
+--
+-- bc :: Int -> LExp -> [BC] -> [BC]
+-- bc top (LV (Glob n)) c = [CALL n] ++ c
+-- bc top (LV (Loc i)) c = [PUSH (top-i)] ++ c
+-- bc top (LApp tc fn args) c
+-- = bcArgs top args ++
+-- if tc then [SLIDE top (length args), TAILCALL fn]
+-- else [CALL fn] ++ c
+-- bc top (LCon tag _ args) c
+-- = bcArgs top args ++ [MKCON tag (length args)] ++ c
+-- bc top (LConst i) c = [PUSHCONST i] ++ c
+-- bc top (LCase e alts) c = bc top e [] ++
+-- if constCase alts then bcCaseConst top alts
+-- else bcCase top alts
+-- ++ c
+-- bc top (LLet _ v e) c = bc top v [] ++ bc (top + 1) e [] ++ c
+-- bc top (LOp prim args) c = bcArgs top args ++ [OP prim] ++ c
+--
+-- bcArgs top [] = []
+-- bcArgs top (x : xs) = bc top x [] ++ bcArgs (top + 1) xs
+--
+-- constCase (LConstCase _ _ : _) = True
+-- constCase (LConCase _ _ _ _ : _) = False
+-- constCase (_ : xs) = constCase xs
+-- constCase _ = False
+--
+-- bcCase top xs = [CASE (mapMaybe (conClause top) xs) (defaultCase top xs)]
+-- bcCaseConst top xs = [CONSTCASE (mapMaybe (constClause top) xs) (defaultCase top xs)]
+--
+-- conClause top (LConCase tag _ args e) = Just (tag, GETARGS (length args) :
+-- bc (top + length args) e []
+-- ++ [SLIDE (length args) 1])
+-- conClause top _ = Nothing
+--
+-- constClause top (LConstCase c e) = Just (c, bc top e [])
+-- constClause top _ = Nothing
+--
+-- defaultCase top [] = Nothing
+-- defaultCase top (LDefaultCase e : xs) = Just (bc top e [])
+-- defaultCase top (_ : xs) = defaultCase top xs
View
13 src/IRTS/LParser.hs
@@ -3,7 +3,7 @@ module IRTS.LParser where
import Core.CoreParser
import Core.TT
import IRTS.Lang
-import IRTS.Bytecode
+import IRTS.Simplified
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Error
@@ -47,9 +47,9 @@ fovm f = do defs <- parseFOVM f
let ctxtIn = addAlist tagged emptyContext
let checked = checkDefs ctxtIn tagged
print checked
- case checked of
- OK c -> do let bc = mapMaybe toBC c
- print bc
+-- case checked of
+-- OK c -> do let bc = mapMaybe toBC c
+-- print bc
parseFOVM :: FilePath -> IO [(Name, LDecl)]
parseFOVM fname = do putStrLn $ "Reading " ++ fname
@@ -92,11 +92,12 @@ pLExp' = try (do reserved "printNum"; e <- pLExp
return (LOp LPrintNum [e]))
<|> try (do reserved "print"; e <- pLExp
return (LOp LPrintStr [e]))
- <|> try (do x <- iName [];
+ <|> try (do tc <- option False (do lchar '%'; reserved "tc"; return True)
+ x <- iName [];
lchar '('
args <- sepBy pLExp (lchar ',')
lchar ')'
- if null args then return (LV (Glob x)) else return (LApp x args))
+ if null args then return (LV (Glob x)) else return (LApp tc x args))
<|> do lchar '('; e <- pLExp; lchar ')'; return e
<|> pLConst
<|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
View
63 src/IRTS/Lang.hs
@@ -6,7 +6,7 @@ data LVar = Loc Int | Glob Name
deriving Show
data LExp = LV LVar
- | LApp Name [LExp]
+ | LApp Bool Name [LExp] -- True = tail call
| LLet Name LExp LExp -- name just for pretty printing
| LCon Int Name [LExp]
| LCase LExp [LAlt]
@@ -29,71 +29,10 @@ data LDecl = LFun Name [Name] LExp -- name, arg names, definition
type LDefs = Ctxt LDecl
--- TODO: scope and arity checker.
-
addTags :: [(Name, LDecl)] -> [(Name, LDecl)]
addTags ds = tag 0 ds
where tag i ((n, LConstructor n' t a) : as)
= (n, LConstructor n' i a) : tag (i + 1) as
tag i (x : as) = x : tag i as
tag i [] = []
-checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, LDecl)]
-checkDefs ctxt [] = return []
-checkDefs ctxt (con@(n, LConstructor _ _ _) : xs) = do xs' <- checkDefs ctxt xs
- return (con : xs')
-checkDefs ctxt ((n, LFun n' args exp) : xs)
- = do exp' <- scopecheck ctxt (zip args [0..]) exp
- xs' <- checkDefs ctxt xs
- return ((n, LFun n' args exp') : xs')
-
-scopecheck :: LDefs -> [(Name, Int)] -> LExp -> TC LExp
-scopecheck ctxt env tm = sc env tm where
- sc env (LV (Glob n))
- = case lookup n (reverse env) of -- most recent first
- Just i -> return (LV (Loc i))
- Nothing -> case lookupCtxt Nothing n ctxt of
- [LConstructor _ i ar] ->
- if ar == 0 then return (LCon i n [])
- else fail $ "Codegen error: Constructor " ++ show n ++
- " has arity " ++ show ar
- [_] -> return (LV (Glob n))
- [] -> fail $ "Codegen error: No such variable " ++ show n
- sc env (LApp f args)
- = do args' <- mapM (sc env) args
- case lookupCtxt Nothing f ctxt of
- [LConstructor n tag ar] ->
- if (ar == length args)
- then return $ LCon tag n args'
- else fail $ "Codegen error: Constructor " ++ show f ++
- " has arity " ++ show ar
- [_] -> return $ LApp f args'
- [] -> fail $ "Codegen error: No such variable " ++ show f
- sc env (LCase e alts)
- = do e' <- sc env e
- alts' <- mapM (scalt env) alts
- return (LCase e' alts')
- sc env (LLet n v e)
- = do v' <- sc env v
- e' <- sc (env ++ [(n, length env)]) e
- return (LLet n v' e')
- sc env (LOp prim args)
- = do args' <- mapM (sc env) args
- return (LOp prim args')
- sc env x = return x
-
- scalt env (LConCase i n args e)
- = do let env' = env ++ zip args [length env..]
- tag <- case lookupCtxt Nothing n ctxt of
- [LConstructor _ i ar] ->
- if (length args == ar) then return i
- else fail $ "Codegen error: Constructor " ++ show n ++
- " has arity " ++ show ar
- _ -> fail $ "Codegen error: No constructor " ++ show n
- e' <- sc env' e
- return (LConCase tag n args e')
- scalt env (LConstCase c e) = do e' <- sc env e
- return (LConstCase c e')
- scalt env (LDefaultCase e) = do e' <- sc env e
- return (LDefaultCase e')
-
View
129 src/IRTS/Simplified.hs
@@ -0,0 +1,129 @@
+module IRTS.Simplified where
+
+import IRTS.Lang
+import Core.TT
+import Data.Maybe
+import Control.Monad.State
+
+-- Simplified expressions, where functions/constructors can only be applied
+-- to variables
+
+data SExp = SV LVar
+ | SApp Bool Name [LVar]
+ | SLet Name SExp SExp
+ | SCon Int Name [LVar]
+ | SCase LVar [SAlt]
+ | SConst Const
+ | SOp PrimFn [LVar]
+ deriving Show
+
+data SAlt = SConCase Int Name [Name] SExp
+ | SConstCase Const SExp
+ | SDefaultCase SExp
+ deriving Show
+
+data SDecl = SFun Name [Name] SExp
+ deriving Show
+
+hvar :: State Int Int
+hvar = do h <- get
+ put (h + 1)
+ return h
+
+simplify :: LExp -> State Int SExp
+simplify (LV (Loc i)) = return (SV (Loc i))
+simplify (LV x) = return (SV x)
+simplify (LApp tc n args) = do args' <- mapM sVar args
+ mkapp (SApp tc n) args'
+simplify (LLet n v e) = do v' <- simplify v
+ e' <- simplify e
+ return (SLet n v' e')
+simplify (LCon i n args) = do args' <- mapM sVar args
+ mkapp (SCon i n) args'
+simplify (LCase e alts) = do v <- sVar e
+ alts' <- mapM sAlt alts
+ case v of
+ (x, Nothing) -> return (SCase x alts')
+ (Glob x, Just e) ->
+ return (SLet x e (SCase (Glob x) alts'))
+simplify (LConst c) = return (SConst c)
+simplify (LOp p args) = do args' <- mapM sVar args
+ mkapp (SOp p) args'
+
+sVar (LV x) = return (x, Nothing)
+sVar e = do e' <- simplify e
+ i <- hvar
+ return (Glob (MN i "R"), Just e')
+
+mkapp f args = mkapp' f args [] where
+ mkapp' f [] args = return $ f (reverse args)
+ mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
+ mkapp' f ((Glob x, Just e) : xs) args
+ = do sc <- mkapp' f xs (Glob x : args)
+ return (SLet x e sc)
+
+sAlt (LConCase i n args e) = do e' <- simplify e
+ return (SConCase i n args e')
+sAlt (LConstCase c e) = do e' <- simplify e
+ return (SConstCase c e')
+sAlt (LDefaultCase e) = do e' <- simplify e
+ return (SDefaultCase e')
+
+checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, SDecl)]
+checkDefs ctxt [] = return []
+checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
+ = do xs' <- checkDefs ctxt xs
+ return xs'
+checkDefs ctxt ((n, LFun n' args exp) : xs)
+ = do let sexp = evalState (simplify exp) 0
+ exp' <- scopecheck ctxt (zip args [0..]) sexp
+ xs' <- checkDefs ctxt xs
+ return ((n, SFun n' args exp') : xs')
+
+scopecheck :: LDefs -> [(Name, Int)] -> SExp -> TC SExp
+scopecheck ctxt env tm = sc env tm where
+ sc env (SV (Glob n))
+ = case lookup n (reverse env) of -- most recent first
+ Just i -> return (SV (Loc i))
+ Nothing -> case lookupCtxt Nothing n ctxt of
+ [LConstructor _ i ar] ->
+ if ar == 0 then return (SCon i n [])
+ else fail $ "Codegen error: Constructor " ++ show n ++
+ " has arity " ++ show ar
+ [_] -> return (SV (Glob n))
+ [] -> fail $ "Codegen error: No such variable " ++ show n
+ sc env (SApp tc f args)
+ = do case lookupCtxt Nothing f ctxt of
+ [LConstructor n tag ar] ->
+ if (ar == length args)
+ then return $ SCon tag n args
+ else fail $ "Codegen error: Constructor " ++ show f ++
+ " has arity " ++ show ar
+ [_] -> return $ SApp tc f args
+ [] -> fail $ "Codegen error: No such variable " ++ show f
+ sc env (SCase e alts)
+ = do alts' <- mapM (scalt env) alts
+ return (SCase e alts')
+ sc env (SLet n v e)
+ = do v' <- sc env v
+ e' <- sc (env ++ [(n, length env)]) e
+ return (SLet n v' e')
+ sc env (SOp prim args)
+ = do return (SOp prim args)
+ sc env x = return x
+
+ scalt env (SConCase i n args e)
+ = do let env' = env ++ zip args [length env..]
+ tag <- case lookupCtxt Nothing n ctxt of
+ [LConstructor _ i ar] ->
+ if (length args == ar) then return i
+ else fail $ "Codegen error: Constructor " ++ show n ++
+ " has arity " ++ show ar
+ _ -> fail $ "Codegen error: No constructor " ++ show n
+ e' <- sc env' e
+ return (SConCase tag n args e')
+ scalt env (SConstCase c e) = do e' <- sc env e
+ return (SConstCase c e')
+ scalt env (SDefaultCase e) = do e' <- sc env e
+ return (SDefaultCase e')
+

0 comments on commit ece92fe

Please sign in to comment.
Something went wrong with that request. Please try again.