diff --git a/Grammar.cf b/Grammar.cf index f98631e..dddab37 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -6,6 +6,7 @@ EAnn. Exp3 ::= "(" Exp ":" Type ")"; ELet. Exp3 ::= "let" Bind "in" Exp; EApp. Exp2 ::= Exp2 Exp3; EAdd. Exp1 ::= Exp1 "+" Exp2; +ESub. Exp1 ::= Exp1 "-" Exp2; EAbs. Exp ::= "\\" Ident ":" Type "." Exp; ECase. Exp ::= "case" Exp "of" "{" [CaseMatch] "}" ":" Type; CaseMatch. CaseMatch ::= Case "=>" Exp ; diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 14a24df..107fb5f 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -24,11 +24,10 @@ fibbonaci x = case x of { 0 => 0, 1 => 1, -- abusing overflows to represent negatives like a boss - _ => (fibbonaci (x + 9223372036854775807 + 9223372036854775807)) - + (fibbonaci (x + 9223372036854775807 + 9223372036854775807 + 1)) + _ => (fibbonaci (x - 2)) + + (fibbonaci (x - 1)) } : Int; -faccer : Int -> Int; main : Int; main = fibbonaci 10; diff --git a/src/Compiler.hs b/src/Compiler.hs index f905e0f..bffab3b 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -156,12 +156,12 @@ defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i compileExp :: Exp -> CompilerState () compileExp (EInt int) = emitInt int compileExp (EAdd t e1 e2) = emitAdd t e1 e2 +compileExp (ESub t e1 e2) = emitSub t e1 e2 compileExp (EId (name, _)) = emitIdent name compileExp (EApp t e1 e2) = emitApp t e1 e2 compileExp (EAbs t ti e) = emitAbs t ti e compileExp (ELet binds e) = emitLet binds e compileExp (ECase t e cs) = emitECased t e cs - -- go (ESub e1 e2) = emitSub e1 e2 -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 @@ -258,6 +258,13 @@ emitAdd t e1 e2 = do v <- getNewVar emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) +emitSub :: Type -> Exp -> Exp -> CompilerState () +emitSub t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable (Ident $ show v) (Sub (type2LlvmType t) v1 v2) + -- emitMul :: Exp -> Exp -> CompilerState () -- emitMul e1 e2 = do -- (v1,v2) <- binExprToValues e1 e2 @@ -295,14 +302,6 @@ emitAdd t e1 e2 = do -- emit $ SetVariable $ Ident $ show v -- emit $ Div I64 v1 v2 --- emitSub :: Exp -> Exp -> CompilerState () --- emitSub e1 e2 = do --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Sub I64 v1 v2 - exprToValue :: Exp -> CompilerState LLVMValue exprToValue = \case EInt i -> pure $ VInteger i @@ -340,6 +339,7 @@ type2LlvmType = \case getType :: Exp -> LLVMType getType (EInt _) = I64 getType (EAdd t _ _) = type2LlvmType t +getType (ESub t _ _) = type2LlvmType t getType (EId (_, t)) = type2LlvmType t getType (EApp t _ _) = type2LlvmType t getType (EAbs t _ _) = type2LlvmType t diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 393a1d6..6522bba 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -47,6 +47,12 @@ freeVarsExp localVars = \case e1' = freeVarsExp localVars e1 e2' = freeVarsExp localVars e2 + ESub t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), ASub t e1' e2') + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + + EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') where e' = freeVarsExp (Set.insert par localVars) e @@ -89,6 +95,7 @@ data AnnExp' = AId Id | ALet ABind AnnExp | AApp Type AnnExp AnnExp | AAdd Type AnnExp AnnExp + | ASub Type AnnExp AnnExp | AAbs Type Id AnnExp | ACase Type AnnExp [AnnCase] deriving Show @@ -125,6 +132,7 @@ abstractExp (free, exp) = case exp of AInt i -> pure $ EInt i AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) + ASub t e1 e2 -> liftA2 (ESub t) (abstractExp e1) (abstractExp e2) ALet b e -> liftA2 ELet (go b) (abstractExp e) where go (ABind name parms rhs) = do @@ -188,6 +196,11 @@ collectScsExp = \case (scs1, e1') = collectScsExp e1 (scs2, e2') = collectScsExp e2 + ESub t e1 e2 -> (scs1 ++ scs2, ESub t e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + EAbs t par e -> (scs, EAbs t par e') where (scs, e') = collectScsExp e diff --git a/src/Renamer.hs b/src/Renamer.hs index 4dee763..a91615b 100644 --- a/src/Renamer.hs +++ b/src/Renamer.hs @@ -55,6 +55,11 @@ renameExp old_names = \case (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EAdd e1' e2') + ESub e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, ESub e1' e2') + ELet b e -> do (new_names, b) <- renameLocalBind old_names b (new_names', e') <- renameExp new_names e diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs index e5ee467..9cb9c39 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker.hs @@ -78,6 +78,11 @@ infer cxt = \case e1' <- check cxt e1 T.TInt pure (T.EAdd T.TInt e' e1', T.TInt) + ESub e e1 -> do + e' <- check cxt e T.TInt + e1' <- check cxt e1 T.TInt + pure (T.ESub T.TInt e' e1', T.TInt) + EAbs x t e -> do (e', t1) <- infer (insertEnv x t cxt) e let t_abs = TFun t t1 @@ -138,6 +143,11 @@ check cxt exp typ = case exp of e1' <- check cxt e1 T.TInt pure $ T.EAdd T.TInt e' e1' + ESub e e1 -> do + e' <- check cxt e T.TInt + e1' <- check cxt e1 T.TInt + pure $ T.ESub T.TInt e' e1' + EAbs x t e -> do (e', t_e) <- infer (insertEnv x t cxt) e let t1 = TFun t t_e diff --git a/src/TypeCheckerIr.hs b/src/TypeCheckerIr.hs index 2bbf0ea..0e30d0c 100644 --- a/src/TypeCheckerIr.hs +++ b/src/TypeCheckerIr.hs @@ -20,6 +20,7 @@ data Exp | ELet Bind Exp | EApp Type Exp Exp | EAdd Type Exp Exp + | ESub Type Exp Exp | EAbs Type Id Exp | ECase Type Exp [(Type, Case)] deriving (C.Eq, C.Ord, C.Show, C.Read) @@ -93,6 +94,13 @@ instance Print Exp where , doc $ showString "+" , prt 2 e2 ] + ESub t e1 e2 -> prPrec i 1 $ concatD + [ doc $ showString "@" + , prt 0 t + , prt 1 e1 + , doc $ showString "-" + , prt 2 e2 + ] EAbs t n e -> prPrec i 0 $ concatD [ doc $ showString "@" , prt 0 t