Permalink
Browse files

Almost working new back end

  • Loading branch information...
1 parent e99339c commit b642db52acfe6140cbebae8ab54a2ba3cc899089 Edwin Brady committed Sep 7, 2012
View
@@ -72,7 +72,7 @@ Executable idris
RTS.Bytecode, RTS.SC, RTS.PreC, RTS.CodegenC,
IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,
- IRTS.CodegenC, IRTS.Defunctionalise,
+ IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Compiler,
Paths_idris
View
@@ -123,7 +123,7 @@ instance Num Nat where
abs x = x
- fromInteger = fromInteger'
+ fromInteger x = fromInteger' x
where
%assert_total
fromInteger' : Int -> Nat
View
@@ -1,7 +1,7 @@
int main(int argc, char* argv[]) {
VM* vm = init_vm(1024000, 1024000);
-
- _idris_main(vm, NULL);
+ _idris__123_runMain0_125_(vm, NULL);
+ //_idris_main(vm, NULL);
#ifdef IDRIS_TRACE
printf("\nStack: %p %p\n", vm->valstack, vm->valstack_top);
printf("Total allocations: %d\n", vm->allocations);
View
@@ -124,6 +124,10 @@ void SLIDE(VM* vm, int args) {
void dumpVal(VAL v) {
int i;
+ if (ISINT(v)) {
+ printf("%ld ", GETINT(v));
+ return;
+ }
switch(v->ty) {
case CON:
printf("%d[", v->info.c.tag);
@@ -132,6 +136,9 @@ void dumpVal(VAL v) {
dumpVal(args[i]);
}
printf("] ");
+ break;
+ default:
+ printf("val");
}
}
@@ -230,7 +237,7 @@ VAL idris_readStr(VM* vm, FILE* h) {
}
VAL idris_strHead(VM* vm, VAL str) {
- return MKINT(GETSTR(str)[0]);
+ return MKINT((i_int)(GETSTR(str)[0]));
}
VAL idris_strTail(VM* vm, VAL str) {
@@ -249,7 +256,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) {
}
VAL idris_strIndex(VM* vm, VAL str, VAL i) {
- return MKINT(GETSTR(str)[GETINT(i)]);
+ return MKINT((i_int)(GETSTR(str)[GETINT(i)]));
}
VAL idris_strRev(VM* vm, VAL str) {
@@ -40,6 +40,7 @@ data BC = ASSIGN Reg Reg
| BASETOP Int -- set BASE = TOP + n
| STOREOLD -- set OLDBASE = BASE
| OP Reg PrimFn [Reg]
+ | ERROR String
deriving Show
toBC :: (Name, SDecl) -> (Name, [BC])
@@ -55,7 +56,7 @@ bc :: Reg -> SExp -> Bool -> -- returning
[BC]
bc reg (SV (Glob n)) r = bc reg (SApp False n []) r
bc reg (SV (Loc i)) r = assign reg (L i) ++ clean r
-bc reg (SApp False f vs) r
+bc reg (SApp _ f vs) r
= RESERVE (length vs) : moveReg 0 vs
++ [STOREOLD, BASETOP 0, ADDTOP (length vs), CALL f] ++
assign reg RVal ++ clean r
@@ -71,6 +72,7 @@ bc reg (SCon i _ vs) r = MKCON reg i (map getL vs) : clean r
bc reg (SConst i) r = ASSIGNCONST reg i : clean r
bc reg (SOp p vs) r = OP reg p (map getL vs) : clean r
where getL (Loc x) = L x
+bc reg (SError str) r = [ERROR str]
bc reg (SCase (Loc l) alts) r
| isConst alts = constCase reg (L l) alts r
| otherwise = conCase reg (L l) alts r
@@ -135,6 +135,7 @@ bcc i (FOREIGNCALL l LANG_C rty fn args)
c_irts rty (creg l ++ " = ")
(fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"
where fcall (t, arg) = irts_c t (creg arg)
+bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); exit(-1);"
-- bcc i _ = indent i ++ "// not done yet\n"
c_irts FInt l x = l ++ "MKINT((i_int)(" ++ x ++ ")"
@@ -220,6 +221,7 @@ doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"
doOp v LStrCons [x, y] = v ++ "idris_strCons(vm, " ++ creg x ++ "," ++ creg y ++ ")"
doOp v LStrIndex [x, y] = v ++ "idris_strIndex(vm, " ++ creg x ++ "," ++ creg y ++ ")"
doOp v LStrRev [x] = v ++ "idris_strRev(vm, " ++ creg x ++ ")"
+doOp v LNoOp [x] = ""
doOp _ _ _ = "FAIL"
tempfile :: IO (FilePath, Handle)
@@ -38,49 +38,51 @@ addApps defs o@(n, LConstructor _ _ _) = o
addApps defs (n, LFun _ args e) = (n, LFun n args (aa args e))
where
aa env (LV (Glob n)) | n `elem` env = LV (Glob n)
- | otherwise = aa env (LApp False n [])
+ | otherwise = aa env (LApp False (LV (Glob n)) [])
-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
- aa env (LApp tc n args)
+ aa env (LApp tc (LV (Glob n)) args)
= let args' = map (aa env) args in
case lookupCtxt Nothing n defs of
- [LConstructor _ i ar] -> LApp tc n args'
+ [LConstructor _ i ar] -> LApp tc (LV (Glob n)) args'
[LFun _ as _] -> let arity = length as in
fixApply tc n args' arity
[] -> chainAPPLY (LV (Glob n)) args'
aa env (LLazyApp n args)
= let args' = map (aa env) args in
case lookupCtxt Nothing n defs of
- [LConstructor _ i ar] -> LApp False n args'
+ [LConstructor _ i ar] -> LApp False (LV (Glob n)) args'
[LFun _ as _] -> let arity = length as in
fixLazyApply n args' arity
[] -> chainAPPLY (LV (Glob n)) args'
+ aa env (LForce e) = eEVAL (aa env e)
aa env (LLet n v sc) = LLet n (aa env v) (aa (n : env) sc)
aa env (LCon i n args) = LCon i n (map (aa env) args)
aa env (LCase e alts) = LCase (eEVAL (aa env e)) (map (aaAlt env) alts)
aa env (LConst c) = LConst c
aa env (LForeign l t n args) = LForeign l t n (map (aaF env) args)
aa env (LOp f args) = LOp f (map (eEVAL . (aa env)) args)
+ aa env (LError e) = LError e
aaF env (t, e) = (t, eEVAL (aa env e))
aaAlt env (LConCase i n args e) = LConCase i n args (aa (args ++ env) e)
aaAlt env (LConstCase c e) = LConstCase c (aa env e)
aaAlt env (LDefaultCase e) = LDefaultCase (aa env e)
- eEVAL x = LApp False (MN 0 "EVAL") [x]
-
fixApply tc n args ar
- | length args == ar = LApp tc n args
- | length args < ar = LApp tc (mkUnderCon n (ar - length args)) args
- | length args > ar = chainAPPLY (LApp tc n (take ar args)) (drop ar args)
+ | length args == ar = LApp tc (LV (Glob n)) args
+ | length args < ar = LApp tc (LV (Glob (mkUnderCon n (ar - length args)))) args
+ | length args > ar = chainAPPLY (LApp tc (LV (Glob n)) (take ar args)) (drop ar args)
fixLazyApply n args ar
- | length args == ar = LApp False (mkFnCon n) args
- | length args < ar = LApp False (mkUnderCon n (ar - length args)) args
- | length args > ar = chainAPPLY (LApp False n (take ar args)) (drop ar args)
+ | length args == ar = LApp False (LV (Glob (mkFnCon n))) args
+ | length args < ar = LApp False (LV (Glob (mkUnderCon n (ar - length args)))) args
+ | length args > ar = chainAPPLY (LApp False (LV (Glob n)) (take ar args)) (drop ar args)
chainAPPLY f [] = f
- chainAPPLY f (a : as) = chainAPPLY (LApp False (MN 0 "APPLY") [f, a]) as
+ chainAPPLY f (a : as) = chainAPPLY (LApp False (LV (Glob (MN 0 "APPLY"))) [f, a]) as
+
+eEVAL x = LApp False (LV (Glob (MN 0 "EVAL"))) [x]
data EvalApply a = EvalCase a
| ApplyCase a
@@ -90,17 +92,17 @@ data EvalApply a = EvalCase a
-- data constuctors, and whether to handle them in EVAL or APPLY
toCons :: (Name, Int) -> [(Name, Int, EvalApply LAlt)]
-toCons (n, i) = (mkFnCon n, i,
- EvalCase (LConCase (-1) (mkFnCon n) (take i (genArgs 0))
- (LApp False n (map (LV . Glob) (take i (genArgs 0))))))
- :
- mkApplyCase n 0 i
+toCons (n, i)
+ = (mkFnCon n, i,
+ EvalCase (LConCase (-1) (mkFnCon n) (take i (genArgs 0))
+ (eEVAL (LApp False (LV (Glob n)) (map (LV . Glob) (take i (genArgs 0)))))))
+ : mkApplyCase n 0 i
mkApplyCase fname n ar | n == ar = []
mkApplyCase fname n ar
= let nm = mkUnderCon fname (ar - n) in
(nm, n, ApplyCase (LConCase (-1) nm (take n (genArgs 0))
- (LApp False (mkUnderCon fname (ar - (n + 1)))
+ (LApp False (LV (Glob (mkUnderCon fname (ar - (n + 1)))))
(map (LV . Glob) (take n (genArgs 0) ++
[MN 0 "arg"])))))
: mkApplyCase fname (n + 1) ar
@@ -116,7 +118,8 @@ mkEval xs = (MN 0 "EVAL", LFun (MN 0 "EVAL") [MN 0 "arg"]
mkApply :: [(Name, Int, EvalApply LAlt)] -> (Name, LDecl)
mkApply xs = (MN 0 "APPLY", LFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"]
- (LCase (LApp False (MN 0 "EVAL") [LV (Glob (MN 0 "fn"))])
+ (LCase (LApp False (LV (Glob (MN 0 "EVAL")))
+ [LV (Glob (MN 0 "fn"))])
(mapMaybe applyCase xs)))
where
applyCase (n, t, ApplyCase x) = Just x
View
@@ -50,7 +50,7 @@ fovm f = do defs <- parseFOVM f
let (nexttag, tagged) = addTags 0 (liftAll defs)
let ctxtIn = addAlist tagged emptyContext
let defuns = defunctionalise nexttag ctxtIn
--- print defuns
+ putStrLn $ showSep "\n" (map show (toAlist defuns))
let checked = checkDefs defuns (toAlist defuns)
-- print checked
case checked of
@@ -135,7 +135,7 @@ pLExp' = try (do lchar '%'; pCast)
then if lazy then return (LLazyApp x [])
else return (LV (Glob x))
else if lazy then return (LLazyApp x args)
- else return (LApp tc x args))
+ else return (LApp tc (LV (Glob x)) args))
<|> do lchar '('; e <- pLExp; lchar ')'; return e
<|> pLConst
<|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp
View
@@ -7,16 +7,18 @@ data LVar = Loc Int | Glob Name
deriving Show
data LExp = LV LVar
- | LApp Bool Name [LExp] -- True = tail call
+ | LApp Bool LExp [LExp] -- True = tail call
| LLazyApp Name [LExp] -- True = tail call
| LLazyExp LExp
+ | LForce LExp -- make sure Exp is evaluted
| LLet Name LExp LExp -- name just for pretty printing
| LLam [Name] LExp -- lambda, lifted out before compiling
| LCon Int Name [LExp]
| LCase LExp [LAlt]
| LConst Const
| LForeign FLang FType String [(FType, LExp)]
| LOp PrimFn [LExp]
+ | LError String
deriving Show
data PrimFn = LPlus | LMinus | LTimes | LDiv | LEq | LLt | LLe | LGt | LGe
@@ -31,6 +33,7 @@ data PrimFn = LPlus | LMinus | LTimes | LDiv | LEq | LLt | LLe | LGt | LGe
| LFSqrt | LFFloor | LFCeil
| LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev
+ | LNoOp
deriving Show
-- Supported target languages for foreign calls
@@ -85,22 +88,29 @@ addFn fn d = do LS n i ds <- get
lift :: [Name] -> LExp -> State LiftState LExp
lift env (LV v) = return (LV v)
-lift env (LApp tc n args) = do args' <- mapM (lift env) args
- return (LApp tc n args')
+lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args
+ return (LApp tc (LV (Glob n)) args')
+lift env (LApp tc f args) = do f' <- lift env f
+ fn <- getNextName
+ addFn fn (LFun fn env f')
+ args' <- mapM (lift env) args
+ return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args'))
lift env (LLazyApp n args) = do args' <- mapM (lift env) args
return (LLazyApp n args')
lift env (LLazyExp (LConst c)) = return (LConst c)
lift env (LLazyExp e) = do e' <- lift env e
fn <- getNextName
addFn fn (LFun fn env e')
return (LLazyApp fn (map (LV . Glob) env))
+lift env (LForce e) = do e' <- lift env e
+ return (LForce e')
lift env (LLet n v e) = do v' <- lift env v
e' <- lift (env ++ [n]) e
return (LLet n v' e')
lift env (LLam args e) = do e' <- lift (env ++ args) e
fn <- getNextName
addFn fn (LFun fn (env ++ args) e')
- return (LApp False fn (map (LV . Glob) env))
+ return (LApp False (LV (Glob fn)) (map (LV . Glob) env))
lift env (LCon i n args) = do args' <- mapM (lift env) args
return (LCon i n args')
lift env (LCase e alts) = do alts' <- mapM liftA alts
@@ -121,7 +131,7 @@ lift env (LForeign l t s args) = do args' <- mapM (liftF env) args
return (t, e')
lift env (LOp f args) = do args' <- mapM (lift env) args
return (LOp f args')
-
+lift env (LError str) = return $ LError str
@@ -16,6 +16,7 @@ data SExp = SV LVar
| SConst Const
| SForeign FLang FType String [(FType, LVar)]
| SOp PrimFn [LVar]
+ | SError String
deriving Show
data SAlt = SConCase Int Int Name [Name] SExp
@@ -42,7 +43,8 @@ simplify tl (LV (Glob x))
case lookupCtxt Nothing x ctxt of
[LConstructor _ t 0] -> return $ SCon t x []
_ -> return $ SV (Glob x)
-simplify tl (LApp tc n args) = do args' <- mapM sVar args
+simplify tl (LApp tc (LV (Glob n)) args)
+ = do args' <- mapM sVar args
mkapp (SApp (tl || tc) n) args'
simplify tl (LForeign lang ty fn args)
= do args' <- mapM sVar (map snd args)
@@ -62,6 +64,7 @@ simplify tl (LCase e alts) = do v <- sVar e
simplify tl (LConst c) = return (SConst c)
simplify tl (LOp p args) = do args' <- mapM sVar args
mkapp (SOp p) args'
+simplify tl (LError str) = return $ SError str
sVar (LV (Glob x))
= do ctxt <- ldefs
@@ -115,7 +118,8 @@ scopecheck ctxt env tm = sc env tm where
Just i -> do lvar i; return (SV (Loc i))
Nothing -> case lookupCtxt Nothing n ctxt of
[LConstructor _ i ar] ->
- if ar == 0 then return (SCon i n [])
+ if True -- ar == 0
+ then return (SCon i n [])
else fail $ "Codegen error: Constructor " ++ show n ++
" has arity " ++ show ar
[_] -> return (SV (Glob n))
@@ -124,7 +128,7 @@ scopecheck ctxt env tm = sc env tm where
= do args' <- mapM (scVar env) args
case lookupCtxt Nothing f ctxt of
[LConstructor n tag ar] ->
- if (ar == length args)
+ if True -- (ar == length args)
then return $ SCon tag n args'
else fail $ "Codegen error: Constructor " ++ show f ++
" has arity " ++ show ar
@@ -138,7 +142,7 @@ scopecheck ctxt env tm = sc env tm where
= do args' <- mapM (scVar env) args
case lookupCtxt Nothing f ctxt of
[LConstructor n tag ar] ->
- if (ar == length args)
+ if True -- (ar == length args)
then return $ SCon tag n args'
else fail $ "Codegen error: Constructor " ++ show f ++
" has arity " ++ show ar
@@ -172,7 +176,8 @@ scopecheck ctxt env tm = sc env tm where
= 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
+ if True -- (length args == ar)
+ then return i
else fail $ "Codegen error: Constructor " ++ show n ++
" has arity " ++ show ar
_ -> fail $ "Codegen error: No constructor " ++ show n
@@ -7,7 +7,7 @@ import Core.TT
import Core.Evaluate
import Core.Elaborate hiding (Tactic(..))
import Core.Typecheck
-import RTS.SC
+import IRTS.Lang
import Util.Pretty
import Paths_idris
@@ -66,7 +66,7 @@ data IState = IState { tt_ctxt :: Context,
syntax_keywords :: [String],
imported :: [FilePath],
idris_prims :: [(Name, ([E.Name], E.Term))],
- idris_scprims :: Prims,
+ idris_scprims :: [(Name, (Int, PrimFn))],
idris_objs :: [FilePath],
idris_libs :: [String],
idris_hdrs :: [String],
Oops, something went wrong. Retry.

0 comments on commit b642db5

Please sign in to comment.