├── LICENSE ├── README.md ├── idris-malfunction.cabal ├── pythag.idr ├── src ├── IRTS │ └── CodegenMalfunction.hs └── Main.hs └── stack.yaml /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Stephen Dolan 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Idris backend for Malfunction 2 | 3 | Compiles Idris to [Malfunction](https://github.com/stedolan/malfunction) 4 | 5 | It seems to go pretty fast: 6 | 7 | $ idris pythag.idr -o pythag-idris 8 | $ idris pythag.idr --codegen malfunction -o pythag-malfunction 9 | $ time ./pythag-idris > /dev/null 10 | 11 | real 0m13.102s 12 | user 0m13.084s 13 | sys 0m0.004s 14 | $ time ./pythag-malfunction > /dev/null 15 | 16 | real 0m1.096s 17 | user 0m1.092s 18 | sys 0m0.000s 19 | $ 20 | -------------------------------------------------------------------------------- /idris-malfunction.cabal: -------------------------------------------------------------------------------- 1 | -- Initial idris-malfunction.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: idris-malfunction 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: MIT 9 | license-file: LICENSE 10 | author: Stephen Dolan 11 | maintainer: stephen.dolan@cl.cam.ac.uk 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable idris-codegen-malfunction 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base 23 | hs-source-dirs: src 24 | default-language: Haskell2010 25 | build-depends: containers 26 | build-depends: idris 27 | build-depends: process 28 | build-depends: directory 29 | -------------------------------------------------------------------------------- /pythag.idr: -------------------------------------------------------------------------------- 1 | -- Example stolen from https://github.com/edwinb/idris-php, 2 | -- with the numbers changed to make it run for longer 3 | 4 | module Main 5 | 6 | -- this speeds up the Idris native version a bit. 7 | %flag C "-O3" 8 | 9 | 10 | pythag : Int -> List (Int, Int, Int) 11 | pythag max = [(x, y, z) | z <- [1..max], y <- [1..z], x <- [1..y], 12 | x * x + y *y == z * z] 13 | 14 | main : IO () 15 | main = print (pythag 500) 16 | -------------------------------------------------------------------------------- /src/IRTS/CodegenMalfunction.hs: -------------------------------------------------------------------------------- 1 | module IRTS.CodegenMalfunction(codegenMalfunction) where 2 | 3 | import Idris.Core.TT 4 | import qualified Idris.Core.CaseTree as CaseTree 5 | import IRTS.CodegenCommon 6 | import IRTS.Lang 7 | import IRTS.Simplified 8 | 9 | import Data.List 10 | import Data.Char 11 | import Data.Ord 12 | import qualified Data.Set as S 13 | import qualified Data.Graph as Graph 14 | import Data.Function (on) 15 | import Control.Monad 16 | 17 | import System.Process 18 | import System.Directory 19 | 20 | 21 | data Sexp = S [Sexp] | A String | KInt Int | KStr String 22 | 23 | instance Show Sexp where 24 | show s = render s "" where 25 | render (S s) k = "(" ++ foldr render (") " ++ k) s 26 | render (A s) k = s ++ " " ++ k 27 | render (KInt n) k = show n ++ " " ++ k 28 | render (KStr s) k = show s ++ " " ++ k 29 | 30 | 31 | okChar c = (isAscii c && isAlpha c) || isDigit c || c `elem` ".&|$+-!@#^*~?<>=_" 32 | 33 | cgSym s = A ('$' : chars s) 34 | where 35 | chars (c:cs) | okChar c = c:chars cs 36 | | otherwise = "%" ++ show (ord c) ++ "%" ++ chars cs 37 | chars [] = [] 38 | 39 | codegenMalfunction :: CodeGenerator 40 | codegenMalfunction ci = do 41 | writeFile tmp $ show $ 42 | S (A "module" : shuffle (simpleDecls ci) 43 | [S [A "_", S [A "apply", cgName (sMN 0 "runMain"), KInt 0]], 44 | S [A "export"]]) 45 | callCommand $ "malfunction compile -o '" ++ outputFile ci ++ "' '" ++ tmp ++ "'" 46 | removeFile tmp 47 | where 48 | tmp = "idris_malfunction_output.mlf" 49 | 50 | shuffle decls rest = prelude ++ toBindings (Graph.stronglyConnComp (map toNode decls)) 51 | where 52 | toBindings [] = rest 53 | toBindings (Graph.AcyclicSCC decl : comps) = cgDecl decl : toBindings comps 54 | toBindings (Graph.CyclicSCC decls : comps) = S (A "rec" : map cgDecl decls) : toBindings comps 55 | 56 | toNode decl@(name, SFun _ _ _ body) = 57 | (decl, name, S.toList (free body)) 58 | 59 | freev (Glob n) = S.singleton n 60 | freev (Loc k) = S.empty 61 | 62 | -- stupid over-approximation, since global names not shadowed 63 | free (SV v) = freev v 64 | free (SApp _ n _) = S.singleton n 65 | free (SLet v e1 e2) = S.unions [freev v, free e1, free e2] 66 | free (SUpdate v e) = S.unions [freev v, free e] 67 | free (SCon (Just v) _ n vs) = S.unions (freev v : S.singleton n : map freev vs) 68 | free (SCon Nothing _ n vs) = S.unions (S.singleton n : map freev vs) 69 | free (SCase _ v cases) = S.unions (freev v : map freeCase cases) 70 | free (SChkCase v cases) = S.unions (freev v : map freeCase cases) 71 | free (SProj v _) = freev v 72 | free (SConst _) = S.empty 73 | free (SForeign _ _ args) = S.unions (map (freev . snd) args) 74 | free (SOp _ args) = S.unions (map freev args) 75 | free (SNothing) = S.empty 76 | free (SError s) = S.empty 77 | 78 | freeCase (SConCase _ _ n ns e) = S.unions [S.singleton n, S.fromList ns, free e] 79 | freeCase (SConstCase _ e) = free e 80 | freeCase (SDefaultCase e) = free e 81 | 82 | prelude = [ 83 | S [A"$%strrev", 84 | S [A"lambda", S [A"$s"], 85 | S [A"let", S [A"$n", S [A"-", S [A"length.byte", A"$s"], KInt 1]], 86 | S [A"apply", S[A"global", A"$String", A"$mapi"], 87 | S[A"lambda", S[A"$i", A"$c"], 88 | S[A"load.byte", A"$s", S[A"-", A"$n", A"$i"]]], 89 | A"$s"]]]] 90 | ] 91 | 92 | 93 | cgName :: Name -> Sexp 94 | cgName = cgSym . showCG 95 | 96 | cgVar (Loc n) = cgSym (show n) 97 | cgVar (Glob n) = cgName n 98 | 99 | cgDecl :: (Name, SDecl) -> Sexp 100 | cgDecl (name, SFun _ args i body) = S [cgName name, S [A "lambda", mkargs args, cgExp body]] 101 | where 102 | mkargs [] = S [A "$%unused"] 103 | mkargs args = S $ map (cgVar . Loc . fst) $ zip [0..] args 104 | 105 | cgExp :: SExp -> Sexp 106 | cgExp (SV v) = cgVar v 107 | cgExp (SApp _ fn []) = S [A "apply", cgName fn, KInt 0] 108 | cgExp (SApp _ fn args) = S (A "apply" : cgName fn : map cgVar args) 109 | cgExp (SLet v e body) = S [A "let", S [cgVar v, cgExp e], cgExp body] 110 | cgExp (SUpdate v e) = cgExp e 111 | cgExp (SProj e idx) = S [A "field", KInt (idx + 1), cgVar e] 112 | cgExp (SCon _ tag name args) = S (A "block": S [A "tag", KInt (tag `mod` 200)] : KInt tag : map cgVar args) 113 | cgExp (SCase _ e cases) = cgSwitch e cases 114 | cgExp (SChkCase e cases) = cgSwitch e cases 115 | cgExp (SConst k) = cgConst k 116 | cgExp (SForeign fn ret args) = error "no FFI" 117 | cgExp (SOp prim args) = cgOp prim args 118 | cgExp SNothing = KInt 0 119 | cgExp (SError s) = S [A "apply", S [A "global", A "$Pervasives", A "$failwith"], KStr $ "error: " ++ show s] 120 | 121 | cgSwitch e cases = 122 | S [A "let", S [scr, cgVar e], 123 | S $ [A "switch", scr] ++ 124 | map cgTagGroup taggroups ++ 125 | concatMap cgNonTagCase cases] 126 | where 127 | scr = A "$%sw" 128 | tagcases = concatMap (\c -> case c of 129 | c@(SConCase lv tag n args body) -> [(tag, c)] 130 | _ -> []) cases 131 | taggroups = 132 | map (\cases -> ((fst $ head cases) `mod` 200, map snd cases)) $ 133 | groupBy ((==) `on` ((`mod` 200) . fst)) $ 134 | sortBy (comparing fst) $ tagcases 135 | cgTagGroup (tagmod, cases) = 136 | S [S [A "tag", KInt tagmod], cgTagClass cases] 137 | -- cgTagClass [c] = 138 | -- cgProjections c 139 | cgTagClass cases = 140 | S (A "switch" : S [A "field", KInt 0, scr] : 141 | [S [KInt tag, cgProjections c] | c@(SConCase _ tag _ _ _) <- cases]) 142 | cgProjections (SConCase lv tag n args body) = 143 | S ([A "let"] ++ 144 | zipWith3 (\v i n -> S [cgVar (Loc v), S [A "field", KInt (i+1), scr]]) [lv..] [0..] args ++ 145 | [cgExp body]) 146 | cgNonTagCase (SConCase _ _ _ _ _) = [] 147 | cgNonTagCase (SConstCase (I n) e) = [S [KInt n, cgExp e]] 148 | cgNonTagCase (SConstCase (BI n) e) = [S [KInt (fromInteger n), cgExp e]] 149 | cgNonTagCase (SConstCase (Ch c) e) = [S [KInt (ord c), cgExp e]] 150 | cgNonTagCase (SConstCase k e) = error $ "unsupported constant selector: " ++ show k 151 | cgNonTagCase (SDefaultCase e) = [S [A "_", S [A "tag", A "_"], cgExp e]] 152 | 153 | 154 | arithSuffix (ATInt ITNative) = "" 155 | arithSuffix (ATInt ITChar) = "" 156 | arithSuffix (ATInt ITBig) = ".big" 157 | arithSuffix s = error $ "unsupported arithmetic type: " ++ show s 158 | 159 | 160 | stdlib path args = S (A "apply" : S (A "global" : map (A . ('$':)) path) : map cgVar args) 161 | 162 | pervasive f args = stdlib ["Pervasives", f] args 163 | 164 | cgOp LStrConcat [l, r] = 165 | S [A "apply", S [A "global", A "$Pervasives", A "$^"], cgVar l, cgVar r] 166 | cgOp LStrCons [c, r] = 167 | S [A "apply", S [A "global", A "$Pervasives", A "$^"], 168 | S [A "apply", S [A "global", A "$String", A "$make"], 169 | KInt 1, cgVar c], cgVar r] -- fixme safety 170 | cgOp LWriteStr [_, str] = 171 | S [A "apply", S [A "global", A "$Pervasives", A "$print_string"], cgVar str] 172 | cgOp LReadStr [_] = S [A "apply", S [A "global", A "$Pervasives", A "$read_line"], KInt 0] 173 | cgOp (LPlus t) args = S (A ("+" ++ arithSuffix t) : map cgVar args) 174 | cgOp (LMinus t) args = S (A ("-" ++ arithSuffix t) : map cgVar args) 175 | cgOp (LTimes t) args = S (A ("*" ++ arithSuffix t) : map cgVar args) 176 | cgOp (LSRem t) args = S (A ("%" ++ arithSuffix t) : map cgVar args) 177 | cgOp (LEq t) args = S (A ("==" ++ arithSuffix t) : map cgVar args) 178 | cgOp (LSLt t) args = S (A ("<" ++ arithSuffix t) : map cgVar args) 179 | cgOp (LSGt t) args = S (A (">" ++ arithSuffix t) : map cgVar args) 180 | cgOp (LSLe t) args = S (A ("<=" ++ arithSuffix t) : map cgVar args) 181 | cgOp (LSGe t) args = S (A (">=" ++ arithSuffix t) : map cgVar args) 182 | cgOp (LIntStr ITNative) args = pervasive "string_of_int" args 183 | cgOp (LIntStr ITBig) args = stdlib ["Z", "to_string"] args 184 | cgOp (LChInt _) [x] = cgVar x 185 | cgOp (LIntCh _) [x] = cgVar x 186 | cgOp (LSExt _ _) [x] = cgVar x -- FIXME 187 | cgOp (LTrunc _ _) [x] = cgVar x -- FIXME 188 | cgOp (LStrInt ITNative) [x] = pervasive "int_of_string" [x] 189 | cgOp LStrEq args = stdlib ["String", "equal"] args 190 | cgOp LStrLen [x] = S [A "length.byte", cgVar x] 191 | cgOp LStrHead [x] = S [A "load.byte", cgVar x, KInt 0] 192 | cgOp LStrIndex args = S (A "store.byte" : map cgVar args) 193 | cgOp LStrTail [x] = S [A "apply", S [A "global", A "$String", A "$sub"], cgVar x, KInt 1, 194 | S [A "-", cgOp LStrLen [x], KInt 1]] 195 | cgOp LStrRev [s] = S [A "apply", A "$%strrev", cgVar s] 196 | cgOp p _ = S [A "apply", S [A "global", A "$Pervasives", A "$failwith"], KStr $ "unimplemented: " ++ show p] 197 | 198 | 199 | cgConst (I n) = KInt n 200 | cgConst (BI n) = S [A "i.big", A (show n)] 201 | cgConst (Fl x) = error "no floats" 202 | cgConst (Ch i) = KInt (ord i) 203 | cgConst (Str s) = KStr s 204 | cgConst k = error $ "unimplemented constant " ++ show k 205 | 206 | 207 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Idris.Main 4 | import Idris.Core.TT 5 | import Idris.AbsSyntax 6 | import Idris.ElabDecls 7 | import Idris.REPL 8 | 9 | import IRTS.Compiler 10 | import IRTS.CodegenMalfunction 11 | 12 | import System.Environment 13 | import System.Exit 14 | import Control.Monad 15 | 16 | import Util.System 17 | 18 | data Opts = Opts { inputs :: [FilePath], 19 | output :: FilePath } 20 | 21 | showUsage = do putStrLn "A code generator which is intended to be called by the compiler, not by a user." 22 | putStrLn "Usage: idris-malfunction [-o ]" 23 | exitWith ExitSuccess 24 | 25 | getOpts :: IO Opts 26 | getOpts = do xs <- getArgs 27 | return $ process (Opts [] "a.out") xs 28 | where 29 | process opts ("-o":o:xs) = process (opts { output = o }) xs 30 | process opts ("--interface":xs) = error "this seems important, what do?" 31 | process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs 32 | process opts [] = opts 33 | 34 | malfunction_main :: Opts -> Idris () 35 | malfunction_main opts = do elabPrims 36 | loadInputs (inputs opts) Nothing 37 | mainProg <- elabMain 38 | ir <- compile (Via IBCFormat "malfunction") (output opts) (Just mainProg) 39 | runIO $ codegenMalfunction ir 40 | 41 | main :: IO () 42 | main = do opts <- getOpts 43 | if (null (inputs opts)) 44 | then showUsage 45 | else runMain (malfunction_main opts) 46 | 47 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.2 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.2" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor --------------------------------------------------------------------------------