├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── config.mk ├── idris-llvm.cabal ├── src ├── IRTS │ └── CodegenLLVM.hs ├── Main.hs └── rts │ ├── Makefile │ ├── defs.c │ ├── getline.c │ ├── getline.h │ ├── idris_buffer.c │ ├── idris_buffer.h │ └── rts.h └── test ├── idris001 └── run └── runtest.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # Build artefacts 2 | dist 3 | *.ibc 4 | *.o 5 | *.a 6 | *.so 7 | *.dll 8 | *.dylib 9 | 10 | # Test artefacts 11 | test/tests 12 | test/output 13 | test/*[0-9][0-9][0-9]/output 14 | test/*[0-9][0-9][0-9]/*.exe 15 | test/runtest.exe 16 | test/runtest 17 | .tasty-rerun-log 18 | 19 | # Haskell build tools 20 | cabal-dev/ 21 | .cabal-sandbox 22 | cabal.sandbox.config 23 | cabal.config 24 | .stack-work 25 | .hsenv 26 | 27 | # For convenience 28 | custom.mk 29 | \#* 30 | .\#* 31 | tags 32 | TAGS 33 | 34 | # IDE and editors 35 | *.swp 36 | *~ 37 | .DS_Store 38 | .hpc 39 | *.orig 40 | *.tix 41 | *.dSYM 42 | .projectile 43 | .dir-locals.el 44 | .vscode 45 | .idea -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | before_install: 3 | - sudo add-apt-repository --yes ppa:h-rayflood/llvm 4 | - sudo apt-get update -qq 5 | - sudo apt-get install -qq libgc-dev llvm-3.3 6 | - sudo apt-get install -qq libghc-unordered-containers-dev libghc-mtl-dev libghc-network-dev libghc-xml-dev libghc-transformers-dev libghc-text-dev libghc-utf8-string-dev libghc-vector-dev libghc-split-dev libghc-ansi-terminal-dev libghc-ansi-wl-pprint-dev 7 | # trifecta dependencies 8 | - sudo apt-get install -qq libghc-blaze-builder-dev libghc-blaze-html-dev libghc-bifunctors-dev libghc-hashable-dev libghc-semigroups-dev libghc-semigroupoids-dev libghc-parallel-dev libghc-comonad-dev libghc-terminfo-dev libghc-keys-dev 9 | # test dependency 10 | - sudo apt-get install -qq expect 11 | - cabal install alex-3.1.3 12 | - cabal install idris 13 | install: 14 | - cabal install 15 | - ghc-pkg list 16 | script: 17 | - make -j2 test 18 | 19 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Redistribution and use in source and binary forms, with or without 2 | modification, are permitted provided that the following conditions 3 | are met: 4 | 1. Redistributions of source code must retain the above copyright 5 | notice, this list of conditions and the following disclaimer. 6 | 2. Redistributions in binary form must reproduce the above copyright 7 | notice, this list of conditions and the following disclaimer in the 8 | documentation and/or other materials provided with the distribution. 9 | 3. None of the names of the copyright holders may be used to endorse 10 | or promote products derived from this software without specific 11 | prior written permission. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY 14 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 15 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 16 | PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE 17 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 18 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 19 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR 20 | BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 21 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 22 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 23 | IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | *** End of disclaimer. *** 26 | 27 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build configure install lib_clean test 2 | 3 | include config.mk 4 | -include custom.mk 5 | 6 | install: 7 | $(CABAL) install $(CABALFLAGS) 8 | 9 | build: dist/setup-config 10 | $(CABAL) build $(CABALFLAGS) 11 | 12 | test: 13 | test/idris001/run 14 | 15 | lib_clean: 16 | $(MAKE) -C src/rts clean 17 | 18 | dist/setup-config: 19 | $(CABAL) configure $(CABALFLAGS) 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris-llvm 2 | 3 | This is a LLVM backend for Idris. 4 | 5 | ## Installing 6 | 7 | Idris-llvm uses llvm-hs to bind to LLVM, it requires that a recent LLVM (at the moment LLVM 4.0) is installed in a location that GHC knows about. Required C libraries are the Boehm GC (it could be called "libgc" or "gc") and GMP. 8 | 9 | If the prerequisites are met `cabal install` should be sufficient to build and install idris-llvm. 10 | 11 | ## Usage 12 | 13 | There needs to be a clang executable available to build the programs. gcc will not work as the input files to clang are LLVM files. 14 | 15 | How to build an executable: 16 | ``` 17 | idris myprog.idr --codegen llvm -o myprog 18 | ``` -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | import Distribution.Simple 4 | import Distribution.Simple.BuildPaths (autogenModulesDir) 5 | import Distribution.Simple.InstallDirs as I 6 | import Distribution.Simple.LocalBuildInfo as L 7 | import qualified Distribution.Simple.Setup as S 8 | import qualified Distribution.Simple.Program as P 9 | import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile) 10 | import Distribution.PackageDescription 11 | import Distribution.Text 12 | 13 | import System.FilePath ((), splitDirectories,isAbsolute) 14 | 15 | -- ----------------------------------------------------------------------------- 16 | -- Make Commands 17 | 18 | -- use GNU make on FreeBSD 19 | #if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) 20 | mymake = "gmake" 21 | #else 22 | mymake = "make" 23 | #endif 24 | make verbosity = 25 | P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake 26 | 27 | 28 | idrisLLVMClean _ flags _ _ = do 29 | make verbosity [ "-C", "src/rts", "clean", "IDRIS=idris" ] 30 | where 31 | verbosity = S.fromFlag $ S.cleanVerbosity flags 32 | 33 | idrisLLVMInstall verbosity copy pkg local = do 34 | installLLVMRTS 35 | where 36 | target = datadir $ L.absoluteInstallDirs pkg local copy 37 | installLLVMRTS = do 38 | let target' = target "rts" 39 | putStrLn $ "Installing LLVM runtime in " ++ target 40 | makeInstall "src/rts" target 41 | makeInstall src target = 42 | make verbosity [ "-C", src, "install", "TARGET=" ++ target ] 43 | 44 | idrisLLVMBuild _ flags _ local = do 45 | buildLLVM 46 | where 47 | verbosity = S.fromFlag $ S.buildVerbosity flags 48 | buildLLVM = make verbosity ["-C", "src/rts", "build"] 49 | 50 | main = defaultMainWithHooks $ simpleUserHooks 51 | { postClean = idrisLLVMClean 52 | , postBuild = idrisLLVMBuild 53 | , postCopy = \_ flags pkg local -> 54 | idrisLLVMInstall (S.fromFlag $ S.copyVerbosity flags) 55 | (S.fromFlag $ S.copyDest flags) pkg local 56 | , postInst = \_ flags pkg local -> 57 | idrisLLVMInstall (S.fromFlag $ S.installVerbosity flags) 58 | NoCopyDest pkg local 59 | } 60 | -------------------------------------------------------------------------------- /config.mk: -------------------------------------------------------------------------------- 1 | CC ?=cc 2 | CABAL :=cabal 3 | CFLAGS :=-O2 -Wall -DHAS_PTHREAD $(CFLAGS) 4 | #CABALFLAGS := 5 | ## Disable building of Effects 6 | #CABALFLAGS :=-f NoEffects 7 | 8 | ifneq (, $(findstring bsd, $(MACHINE))) 9 | GMP_INCLUDE_DIR := 10 | else 11 | GMP_INCLUDE_DIR :=-I/usr/local/include 12 | endif 13 | 14 | MACHINE := $(shell $(CC) -dumpmachine) 15 | ifneq (, $(findstring darwin, $(MACHINE))) 16 | OS :=darwin 17 | else 18 | ifneq (, $(findstring cygwin, $(MACHINE))) 19 | OS :=windows 20 | else 21 | ifneq (, $(findstring mingw, $(MACHINE))) 22 | OS :=windows 23 | else 24 | OS :=unix 25 | endif 26 | endif 27 | endif 28 | 29 | ifeq ($(OS),darwin) 30 | SHLIB_SUFFIX :=.dylib 31 | else 32 | ifeq ($(OS),windows) 33 | SHLIB_SUFFIX :=.DLL 34 | else 35 | SHLIB_SUFFIX :=.so 36 | endif 37 | endif 38 | -------------------------------------------------------------------------------- /idris-llvm.cabal: -------------------------------------------------------------------------------- 1 | Name: idris-llvm 2 | Version: 0.0.0.2 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Benjamin Saunders 6 | Maintainer: Niklas Larsson 7 | Build-Type: Custom 8 | Cabal-Version: >= 1.8 9 | Extra-source-files: 10 | llvm/Makefile 11 | llvm/*.c 12 | 13 | Executable idris-codegen-llvm 14 | Main-is: Main.hs 15 | hs-source-dirs: src 16 | 17 | Build-depends: idris 18 | , base 19 | , bytestring 20 | , containers 21 | , directory 22 | , filepath 23 | , haskeline >= 0.7 24 | , mtl 25 | , process 26 | , text 27 | , transformers 28 | , vector 29 | , llvm-hs 30 | , llvm-hs-pure 31 | 32 | other-modules: IRTS.CodegenLLVM 33 | cpp-options: -DIDRIS_LLVM 34 | 35 | if os(linux) 36 | cpp-options: -DLINUX 37 | build-depends: unix < 2.8 38 | if os(freebsd) 39 | cpp-options: -DFREEBSD 40 | build-depends: unix < 2.8 41 | if os(dragonfly) 42 | cpp-options: -DDRAGONFLY 43 | build-depends: unix < 2.8 44 | if os(darwin) 45 | cpp-options: -DMACOSX 46 | build-depends: unix < 2.8 47 | if os(windows) 48 | cpp-options: -DWINDOWS 49 | build-depends: Win32 < 2.4 50 | 51 | ghc-prof-options: -auto-all -caf-all 52 | ghc-options: -threaded -rtsopts -funbox-strict-fields 53 | 54 | -------------------------------------------------------------------------------- /src/IRTS/CodegenLLVM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE CPP, OverloadedStrings #-} 3 | module IRTS.CodegenLLVM (codegenLLVM) where 4 | 5 | import IRTS.CodegenCommon 6 | import IRTS.Lang 7 | import IRTS.Simplified 8 | import IRTS.System 9 | 10 | import qualified Idris.Core.TT as TT 11 | import Idris.Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth, sUN) 12 | 13 | import Util.System 14 | import Paths_idris_llvm 15 | import System.FilePath 16 | 17 | import qualified LLVM 18 | import LLVM.Context 19 | import qualified LLVM.Target as Target 20 | import LLVM.AST 21 | import LLVM.AST.AddrSpace 22 | import LLVM.AST.DataLayout 23 | import qualified LLVM.AST.IntegerPredicate as IPred 24 | import qualified LLVM.AST.FloatingPointPredicate as FPred 25 | import qualified LLVM.AST.Linkage as L 26 | import qualified LLVM.AST.Visibility as V 27 | import qualified LLVM.AST.CallingConvention as CC 28 | import qualified LLVM.AST.Attribute as A 29 | import qualified LLVM.AST.Global as G 30 | import qualified LLVM.AST.Constant as C 31 | import qualified LLVM.AST.Float as F 32 | 33 | import qualified Data.ByteString as B 34 | import qualified Data.ByteString.Short as BS 35 | import Data.Char 36 | import Data.List 37 | import Data.Maybe 38 | import Data.String 39 | import qualified Data.Text as T 40 | import Data.Text.Encoding 41 | import Data.Word 42 | import Data.Map (Map) 43 | import qualified Data.Map as M 44 | import qualified Data.Set as S 45 | import qualified Data.Vector.Unboxed as V 46 | import Control.Applicative 47 | import Control.Monad.RWS 48 | import Control.Monad.Writer 49 | import Control.Monad.State 50 | import Control.Monad.Error 51 | 52 | import qualified System.Info as SI (arch, os) 53 | import System.IO 54 | import System.Directory (removeFile) 55 | import System.Environment 56 | import System.FilePath (()) 57 | import System.Process (rawSystem) 58 | import System.Exit (ExitCode(..)) 59 | import Debug.Trace 60 | 61 | data Target = Target { triple :: String, dataLayout :: DataLayout } 62 | type Machine = String 63 | -- These might want to live in a different file 64 | 65 | 66 | -- TODO These should probably be derived from the triple 67 | #if defined(FREEBSD) || defined(DRAGONFLY) 68 | extraLib = ["-L/usr/local/lib"] 69 | #else 70 | extraLib = [] 71 | #endif 72 | 73 | getRtsDir = do dir <- getDataDir 74 | return $ addTrailingPathSeparator dir 75 | 76 | #if defined(FREEBSD) || defined(DRAGONFLY) 77 | extraInclude = " -I/usr/local/include" 78 | #else 79 | extraInclude = "" 80 | #endif 81 | 82 | -- This is dumb, but needed. 83 | fromSBS :: BS.ShortByteString -> String 84 | fromSBS = T.unpack . decodeUtf8 . BS.fromShort 85 | 86 | 87 | getIncFlags = do dir <- getDataDir 88 | return $ ["-I" ++ dir "rts", extraInclude] 89 | 90 | 91 | -- FIXME: 'optimisation' is no longer a field in CodeGenerator, because 92 | -- optimisation levels at the idris command line are meant to 93 | -- indicate idris optimisation levels, not levels to pass through to 94 | -- back ends. We may need a way to pass back end specific options through. 95 | codegenLLVM :: CodeGenerator 96 | codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci) 97 | (targetCPU ci) 2 98 | (outputFile ci) (outputType ci) 99 | 100 | codegenLLVM' :: [(TT.Name, SDecl)] -> 101 | String -> -- target triple 102 | String -> -- target CPU 103 | Word -> -- Optimization degree 104 | FilePath -> -- output file name 105 | OutputType -> 106 | IO () 107 | codegenLLVM' defs triple cpu optimize file outty = do 108 | defTrip <- Target.getDefaultTargetTriple 109 | let layout = defaultDataLayout LittleEndian 110 | let ast = codegen file (Target (fromSBS defTrip) layout) (map snd defs) 111 | outputModule triple file outty ast 112 | 113 | failInIO :: ErrorT String IO a -> IO a 114 | failInIO = either fail return <=< runErrorT 115 | 116 | getCompiler = fromMaybe "clang" <$> lookupEnv "IDRIS_CLANG" 117 | 118 | outputModule :: Machine -> FilePath -> OutputType -> Module -> IO () 119 | outputModule _ file Raw m = do 120 | withContext $ \ctx -> 121 | LLVM.withModuleFromAST ctx m $ \mod -> 122 | LLVM.writeLLVMAssemblyToFile (LLVM.File file) mod 123 | outputModule _ file Object m = error "Not implemented yet" 124 | outputModule _ file Executable m = do 125 | withContext $ \ctx -> 126 | LLVM.withModuleFromAST ctx m $ \mod -> 127 | withTmpFile ".ll" $ \tf -> do 128 | LLVM.writeLLVMAssemblyToFile (LLVM.File tf) mod 129 | cc <- getCompiler 130 | rts <- getRtsDir 131 | _ <- rawSystem cc ([tf, rts ++ "libidris_rts.a", "-lgc", "-lgmp", "-o" ++ file]) 132 | return () 133 | 134 | 135 | withTmpFile :: String -> (FilePath -> IO a) -> IO a 136 | withTmpFile suffix f = do 137 | (path, handle) <- tempfile suffix 138 | hClose handle 139 | result <- f path 140 | removeFile path 141 | return result 142 | 143 | ierror :: String -> a 144 | ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg 145 | 146 | 147 | -- Type helpers 148 | --------------- 149 | glRef n = C.GlobalReference (tyRef n) (mkName n) 150 | globalRef n = ConstantOperand $ glRef n 151 | 152 | 153 | i8 = IntegerType 8 154 | i16 = IntegerType 16 155 | i32 = IntegerType 32 156 | i64 = IntegerType 64 157 | 158 | f32 = FloatingPointType FloatFP 159 | f64 = FloatingPointType DoubleFP 160 | 161 | -- pointers 162 | ptr t = PointerType t (AddrSpace 0) 163 | ptrI8 = ptr i8 164 | ppI8 = ptr ptrI8 165 | 166 | pmpz = PointerType mpzTy (AddrSpace 0) 167 | 168 | -- value helpers 169 | ---------------- 170 | 171 | ci32 v = ConstantOperand (C.Int 32 v) 172 | 173 | mainDef :: Global 174 | mainDef = 175 | functionDefaults 176 | { G.returnType = i32 177 | , G.parameters = 178 | ([ Parameter i32 (mkName "argc") [] 179 | , Parameter ppI8 (mkName "argv") [] 180 | ], False) 181 | , G.name = mkName "main" 182 | , G.basicBlocks = 183 | [ BasicBlock (UnName 0) 184 | [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC 185 | , Do $ simpleCall "__gmp_set_memory_functions" 186 | [ globalRef "__idris_gmpMalloc" 187 | , globalRef "__idris_gmpRealloc" 188 | , globalRef "__idris_gmpFree" 189 | ] 190 | , Do $ Store False (globalRef "__idris_argc") 191 | (LocalReference i32 (mkName "argc")) Nothing 0 [] 192 | , Do $ Store False (globalRef "__idris_argv") 193 | (LocalReference ppI8 (mkName "argv")) Nothing 0 [] 194 | , UnName 1 := idrCall "{runMain_0}" [] ] 195 | (Do $ Ret (Just (ci32 0)) []) 196 | ]} 197 | 198 | initDefs :: Target -> [Definition] 199 | initDefs tgt = 200 | [ TypeDefinition (mkName "valTy") 201 | (Just $ StructureType False 202 | [ i32 203 | , ArrayType 0 (ptr valueType) 204 | ]) 205 | , TypeDefinition (mkName "mpz") 206 | (Just $ StructureType False [i32, i32, ptr intPtr]) 207 | , GlobalDefinition $ globalVariableDefaults 208 | { G.name = mkName "__idris_intFmtStr" 209 | , G.linkage = L.Internal 210 | , G.isConstant = True 211 | , G.unnamedAddr = Just G.GlobalAddr 212 | , G.type' = ArrayType 5 (IntegerType 8) 213 | , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0]) 214 | } 215 | , rtsFun "intStr" ptrI8 [IntegerType 64] 216 | [ BasicBlock (UnName 0) 217 | [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)] 218 | , UnName 2 := simpleCall "snprintf" 219 | [ LocalReference ptrI8 (UnName 1) 220 | , ConstantOperand (C.Int (tgtWordSize tgt) 21) 221 | , ConstantOperand $ C.GetElementPtr True (glRef "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0] 222 | , LocalReference f64 (UnName 0) 223 | ] 224 | ] 225 | (Do $ Ret (Just (LocalReference ptrI8 (UnName 1))) []) 226 | ] 227 | , GlobalDefinition $ globalVariableDefaults 228 | { G.name = mkName "__idris_floatFmtStr" 229 | , G.linkage = L.Internal 230 | , G.isConstant = True 231 | , G.unnamedAddr = Just G.GlobalAddr 232 | , G.type' = ArrayType 3 (IntegerType 8) 233 | , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%g" ++ [C.Int 8 0]) 234 | } 235 | , rtsFun "floatStr" ptrI8 [f64] 236 | [ BasicBlock (UnName 0) 237 | [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)] 238 | , UnName 2 := simpleCall "snprintf" 239 | [ LocalReference ptrI8 (UnName 1) 240 | , ConstantOperand (C.Int (tgtWordSize tgt) 21) 241 | , ConstantOperand $ C.GetElementPtr True (glRef "__idris_floatFmtStr") [C.Int 32 0, C.Int 32 0] 242 | , LocalReference f64 (UnName 0) 243 | ] 244 | ] 245 | (Do $ Ret (Just (LocalReference ptrI8 (UnName 1))) []) 246 | ] 247 | , exfun "llvm.sin.f64" (f64) [ f64 ] False 248 | , exfun "llvm.cos.f64" (f64) [ f64 ] False 249 | , exfun "llvm.pow.f64" (f64) [ f64 ] False 250 | , exfun "llvm.ceil.f64" (f64) [ f64 ] False 251 | , exfun "llvm.floor.f64" (f64) [ f64 ] False 252 | , exfun "llvm.exp.f64" (f64) [ f64 ] False 253 | , exfun "llvm.log.f64" (f64) [ f64 ] False 254 | , exfun "llvm.sqrt.f64" (f64) [ f64 ] False 255 | , exfun "tan" (f64) [ f64 ] False 256 | , exfun "asin" (f64) [ f64 ] False 257 | , exfun "acos" (f64) [ f64 ] False 258 | , exfun "atan" (f64) [ f64 ] False 259 | , exfun "llvm.trap" VoidType [] False 260 | , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False 261 | , exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False 262 | , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True 263 | , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False 264 | , exfun "strlen" intPtr [ptrI8] False 265 | , exfun "GC_init" VoidType [] False 266 | , exfun "GC_malloc" ptrI8 [intPtr] False 267 | , exfun "GC_malloc_atomic" ptrI8 [intPtr] False 268 | , exfun "__gmp_set_memory_functions" VoidType 269 | [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0) 270 | , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0) 271 | , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0) 272 | ] False 273 | , exfun "__gmpz_init" VoidType [pmpz] False 274 | , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False 275 | , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False 276 | , exfun "__gmpz_get_ui" intPtr [pmpz] False 277 | , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False 278 | , exfun "__gmpz_fdiv_q_2exp" VoidType [pmpz, pmpz, intPtr] False 279 | , exfun "__gmpz_mul_2exp" VoidType [pmpz, pmpz, intPtr] False 280 | , exfun "__gmpz_get_d" (f64) [pmpz] False 281 | , exfun "__gmpz_set_d" VoidType [pmpz, f64] False 282 | , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False 283 | , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False 284 | , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False 285 | , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False 286 | , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway 287 | , exfun "__idris_readChars" ptrI8 [i32, ptrI8] False 288 | , exfun "__idris_writeStr" i32 [ptrI8, ptrI8] False 289 | , exfun "__idris_registerPtr" ptrI8 [ptrI8, i32] False 290 | , exfun "__idris_getRegisteredPtr" ptrI8 [ptrI8] False 291 | , exfun "__idris_sizeofPtr" i32 [] False 292 | , exfun "__idris_stdin" ptrI8 [] False 293 | , exfun "__idris_stdout" ptrI8 [] False 294 | , exfun "__idris_stderr" ptrI8 [] False 295 | , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False 296 | , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False 297 | , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False 298 | , exfun "__idris_strRev" ptrI8 [ptrI8] False 299 | , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False 300 | , exfun "strtod" (f64) [ptrI8, PointerType ptrI8 (AddrSpace 0)] False 301 | , exfun "putErr" VoidType [ptrI8] False 302 | , exfun "printf" i32 [ptrI8] True 303 | , exVar "__idris_argc" (IntegerType 32) 304 | , exVar "__idris_argv" (PointerType ptrI8 (AddrSpace 0)) 305 | , GlobalDefinition mainDef 306 | ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"] 307 | where 308 | intPtr = IntegerType (tgtWordSize tgt) 309 | mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False 310 | 311 | rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition 312 | rtsFun name rty argtys def = 313 | GlobalDefinition $ functionDefaults 314 | { G.linkage = L.Internal 315 | , G.returnType = rty 316 | , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False) 317 | , G.name = mkName $ "__idris_" ++ name 318 | , G.basicBlocks = def 319 | } 320 | 321 | exfun :: String -> Type -> [Type] -> Bool -> Definition 322 | exfun name rty argtys vari = 323 | GlobalDefinition $ functionDefaults 324 | { G.returnType = rty 325 | , G.name = mkName name 326 | , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari) 327 | } 328 | exVar :: String -> Type -> Definition 329 | exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = mkName name, G.type' = ty } 330 | 331 | 332 | codegen :: String -> Target -> [SDecl] -> Module 333 | codegen file tgt defs = Module { 334 | moduleName = "idris", 335 | moduleSourceFileName = fromString file, 336 | moduleDataLayout = Just . dataLayout $ tgt, 337 | moduleTargetTriple = Just (fromString $ triple tgt), 338 | moduleDefinitions = initDefs tgt ++ globals ++ gendefs 339 | } 340 | where 341 | (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt initialMGS 342 | 343 | valueType :: Type 344 | valueType = NamedTypeReference (mkName "valTy") 345 | 346 | nullValue :: C.Constant 347 | nullValue = C.Null (PointerType valueType (AddrSpace 0)) 348 | 349 | primTy :: Type -> Type 350 | primTy inner = StructureType False [IntegerType 32, inner] 351 | 352 | mpzTy :: Type 353 | mpzTy = NamedTypeReference (mkName "mpz") 354 | 355 | tyRef :: String -> Type 356 | tyRef = NamedTypeReference . mkName 357 | 358 | conType :: Word64 -> Type 359 | conType nargs = StructureType False 360 | [ IntegerType 32 361 | , ArrayType nargs (PointerType valueType (AddrSpace 0)) 362 | ] 363 | 364 | data MGS = MGS { mgsNextGlobalName :: Word 365 | , mgsForeignSyms :: Map String (FType, [FType]) 366 | } 367 | 368 | type Modgen = RWS Target [Definition] MGS 369 | 370 | initialMGS :: MGS 371 | initialMGS = MGS { mgsNextGlobalName = 0 372 | , mgsForeignSyms = M.empty 373 | } 374 | 375 | cgDef :: SDecl -> Modgen Definition 376 | cgDef (SFun name argNames _ expr) = do 377 | nextGlobal <- gets mgsNextGlobalName 378 | existingForeignSyms <- gets mgsForeignSyms 379 | tgt <- ask 380 | let (_, CGS { nextGlobalName = nextGlobal', foreignSyms = foreignSyms' }, (allocas, bbs, globals)) = 381 | runRWS (do r <- cgExpr expr 382 | case r of 383 | Nothing -> terminate $ Unreachable [] 384 | Just r' -> terminate $ Ret (Just r') []) 385 | (CGR tgt (TT.showCG name)) 386 | (CGS 0 nextGlobal (mkName "begin") [] (map ((\n -> Just (LocalReference (NamedTypeReference n) n)) . mkName . TT.showCG) argNames) existingForeignSyms) 387 | entryTerm = case bbs of 388 | [] -> Do $ Ret Nothing [] 389 | BasicBlock n _ _:_ -> Do $ Br n [] 390 | tell globals 391 | put (MGS { mgsNextGlobalName = nextGlobal', mgsForeignSyms = foreignSyms' }) 392 | return . GlobalDefinition $ functionDefaults 393 | { G.linkage = L.Internal 394 | , G.callingConvention = CC.Fast 395 | , G.name = mkName (TT.showCG name) 396 | , G.returnType = PointerType valueType (AddrSpace 0) 397 | , G.parameters = (flip map argNames $ \argName -> 398 | Parameter (PointerType valueType (AddrSpace 0)) (mkName (TT.showCG argName)) [] 399 | , False) 400 | , G.basicBlocks = 401 | BasicBlock (mkName "entry") 402 | (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas) 403 | entryTerm 404 | : bbs 405 | } 406 | 407 | type CGW = ([(Name, Type)], [BasicBlock], [Definition]) 408 | 409 | type Env = [Maybe Operand] 410 | 411 | data CGS = CGS { nextName :: Word 412 | , nextGlobalName :: Word 413 | , currentBlockName :: Name 414 | , instAccum :: [Named Instruction] 415 | , lexenv :: Env 416 | , foreignSyms :: Map String (FType, [FType]) 417 | } 418 | 419 | data CGR = CGR { target :: Target 420 | , funcName :: String } 421 | 422 | type Codegen = RWS CGR CGW CGS 423 | 424 | getFuncName :: Codegen String 425 | getFuncName = asks funcName 426 | 427 | getGlobalUnName :: Codegen Name 428 | getGlobalUnName = do 429 | i <- gets nextGlobalName 430 | modify $ \s -> s { nextGlobalName = 1 + i } 431 | return (UnName i) 432 | 433 | getUnName :: Codegen Name 434 | getUnName = do 435 | i <- gets nextName 436 | modify $ \s -> s { nextName = 1 + i } 437 | return (UnName i) 438 | 439 | getName :: String -> Codegen Name 440 | getName n = do 441 | i <- gets nextName 442 | modify $ \s -> s { nextName = 1 + i } 443 | return (mkName $ n ++ show i) 444 | 445 | alloca :: Name -> Type -> Codegen () 446 | alloca n t = tell ([(n, t)], [], []) 447 | 448 | terminate :: Terminator -> Codegen () 449 | terminate term = do 450 | name <- gets currentBlockName 451 | insts <- gets instAccum 452 | modify $ \s -> s { instAccum = ierror "Not in a block" 453 | , currentBlockName = ierror "Not in a block" } 454 | tell ([], [BasicBlock name insts (Do term)], []) 455 | 456 | newBlock :: Name -> Codegen () 457 | newBlock name = modify $ \s -> s { instAccum = [] 458 | , currentBlockName = name 459 | } 460 | 461 | inst :: Instruction -> Codegen Operand 462 | inst i = do 463 | n <- getUnName 464 | modify $ \s -> s { instAccum = instAccum s ++ [n := i] } 465 | return $ LocalReference (NamedTypeReference n) n 466 | 467 | ninst :: String -> Instruction -> Codegen Operand 468 | ninst name i = do 469 | n <- getName name 470 | modify $ \s -> s { instAccum = instAccum s ++ [n := i] } 471 | return $ LocalReference (NamedTypeReference n) n 472 | 473 | inst' :: Instruction -> Codegen () 474 | inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] } 475 | 476 | insts :: [Named Instruction] -> Codegen () 477 | insts is = modify $ \s -> s { instAccum = instAccum s ++ is } 478 | 479 | var :: LVar -> Codegen (Maybe Operand) 480 | var (Loc level) = (!! level) <$> gets lexenv 481 | var (Glob n) = return $ Just (globalRef (TT.showCG n)) 482 | 483 | binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand) 484 | binds vals cg = do 485 | envLen <- length <$> gets lexenv 486 | modify $ \s -> s { lexenv = lexenv s ++ vals } 487 | value <- cg 488 | modify $ \s -> s { lexenv = take envLen $ lexenv s } 489 | return value 490 | 491 | replaceElt :: Int -> a -> [a] -> [a] 492 | replaceElt _ val [] = error "replaceElt: Ran out of list" 493 | replaceElt 0 val (x:xs) = val:xs 494 | replaceElt n val (x:xs) = x : replaceElt (n-1) val xs 495 | 496 | alloc' :: Operand -> Codegen Operand 497 | alloc' size = inst $ simpleCall "GC_malloc" [size] 498 | 499 | allocAtomic' :: Operand -> Codegen Operand 500 | allocAtomic' size = inst $ simpleCall "GC_malloc_atomic" [size] 501 | 502 | alloc :: Type -> Codegen Operand 503 | alloc ty = do 504 | size <- sizeOf ty 505 | mem <- alloc' size 506 | inst $ BitCast mem (PointerType ty (AddrSpace 0)) [] 507 | 508 | allocAtomic :: Type -> Codegen Operand 509 | allocAtomic ty = do 510 | size <- sizeOf ty 511 | mem <- allocAtomic' size 512 | inst $ BitCast mem (PointerType ty (AddrSpace 0)) [] 513 | 514 | sizeOf :: Type -> Codegen Operand 515 | sizeOf ty = ConstantOperand . C.PtrToInt 516 | (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1]) 517 | . IntegerType <$> getWordSize 518 | 519 | loadInv :: Operand -> Instruction 520 | loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])] 521 | 522 | tgtWordSize :: Target -> Word32 523 | tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) = 524 | fst . fromJust $ M.lookup (AddrSpace 0) l 525 | 526 | getWordSize :: Codegen Word32 527 | getWordSize = tgtWordSize <$> asks target 528 | 529 | cgExpr :: SExp -> Codegen (Maybe Operand) 530 | cgExpr (SV v) = var v 531 | cgExpr (SApp tailcall fname args) = do 532 | argSlots <- mapM var args 533 | case sequence argSlots of 534 | Nothing -> return Nothing 535 | Just argVals -> do 536 | fn <- var (Glob fname) 537 | Just <$> inst ((idrCall (TT.showCG fname) argVals) 538 | { tailCallKind = if tailcall then Just Tail else Nothing }) 539 | cgExpr (SLet _ varExpr bodyExpr) = do 540 | val <- cgExpr varExpr 541 | binds [val] $ cgExpr bodyExpr 542 | cgExpr (SUpdate (Loc level) expr) = do 543 | val <- cgExpr expr 544 | modify $ \s -> s { lexenv = replaceElt level val (lexenv s) } 545 | return val 546 | cgExpr (SUpdate x expr) = cgExpr expr 547 | cgExpr (SCon _ tag name args) = do 548 | argSlots <- mapM var args 549 | case sequence argSlots of 550 | Nothing -> return Nothing 551 | Just argVals -> do 552 | let ty = conType . fromIntegral . length $ argVals 553 | con <- alloc ty 554 | tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] 555 | inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 [] 556 | forM_ (zip argVals [0..]) $ \(arg, i) -> do 557 | ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) 558 | , ConstantOperand (C.Int 32 1) 559 | , ConstantOperand (C.Int 32 i)] [] 560 | inst' $ Store False ptr arg Nothing 0 [] 561 | ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) [] 562 | inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8] 563 | Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) []) 564 | cgExpr (SCase _ inspect alts) = do 565 | val <- var inspect 566 | case val of 567 | Nothing -> return Nothing 568 | Just v -> cgCase v alts 569 | cgExpr (SChkCase inspect alts) = do 570 | mval <- var inspect 571 | case mval of 572 | Nothing -> return Nothing 573 | Just val -> 574 | do endBBN <- getName "endChkCase" 575 | notNullBBN <- getName "notNull" 576 | originBlock <- gets currentBlockName 577 | isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) [] 578 | terminate $ CondBr isNull endBBN notNullBBN [] 579 | newBlock notNullBBN 580 | ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) [] 581 | flag <- inst $ Load False ptr Nothing 0 [] 582 | isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) [] 583 | conBBN <- getName "constructor" 584 | terminate $ CondBr isVal endBBN conBBN [] 585 | newBlock conBBN 586 | result <- cgCase val alts 587 | caseExitBlock <- gets currentBlockName 588 | case result of 589 | Nothing -> do 590 | terminate $ Unreachable [] 591 | newBlock endBBN 592 | return $ Just val 593 | Just caseVal -> do 594 | terminate $ Br endBBN [] 595 | newBlock endBBN 596 | Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) 597 | [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] []) 598 | cgExpr (SProj conVar idx) = do 599 | val <- var conVar 600 | case val of 601 | Nothing -> return Nothing 602 | Just v -> 603 | do ptr <- inst $ GetElementPtr True v 604 | [ ConstantOperand (C.Int 32 0) 605 | , ConstantOperand (C.Int 32 1) 606 | , ConstantOperand (C.Int 32 (fromIntegral idx)) 607 | ] [] 608 | Just <$> inst (Load False ptr Nothing 0 []) 609 | cgExpr (SConst c) = Just <$> cgConst c 610 | cgExpr (SForeign rty (FStr fname) args) = do 611 | func <- ensureCDecl fname (toFType rty) (map (toFType . fst) args) 612 | argVals <- forM args $ \(fty, v) -> do 613 | v' <- var v 614 | case v' of 615 | Just val -> return $ Just (toFType fty, val) 616 | Nothing -> return Nothing 617 | case sequence argVals of 618 | Nothing -> return Nothing 619 | Just argVals' -> do 620 | argUVals <- mapM (uncurry unbox) argVals' 621 | result <- inst Call { tailCallKind = Nothing 622 | , callingConvention = CC.C 623 | , returnAttributes = [] 624 | , function = Right func 625 | , arguments = map (\v -> (v, [])) argUVals 626 | , functionAttributes = [] 627 | , metadata = [] 628 | } 629 | Just <$> box (toFType rty) result 630 | cgExpr (SOp fn args) = do 631 | argVals <- mapM var args 632 | case sequence argVals of 633 | Just ops -> Just <$> cgOp fn ops 634 | Nothing -> return Nothing 635 | cgExpr SNothing = return . Just . ConstantOperand $ nullValue 636 | cgExpr (SError msg) = do 637 | str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8)) 638 | (cgConst' (TT.Str (msg ++ "\n"))) 639 | inst' $ simpleCall "putErr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0 640 | , C.Int 32 0]] 641 | inst' Call { tailCallKind = Just Tail 642 | , callingConvention = CC.C 643 | , returnAttributes = [] 644 | , function = Right $ globalRef "llvm.trap" 645 | , arguments = [] 646 | , functionAttributes = [Right A.NoReturn] 647 | , metadata = [] 648 | } 649 | return Nothing 650 | 651 | cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand) 652 | cgCase val alts = 653 | case find isConstCase alts of 654 | Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts 655 | Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts 656 | Just (SConstCase _ _) -> cgPrimCase val defExp constAlts 657 | Nothing -> cgConCase val defExp conAlts 658 | where 659 | defExp = getDefExp =<< find isDefCase alts 660 | constAlts = filter isConstCase alts 661 | conAlts = filter isConCase alts 662 | 663 | isConstCase (SConstCase {}) = True 664 | isConstCase _ = False 665 | 666 | isConCase (SConCase {}) = True 667 | isConCase _ = False 668 | 669 | isDefCase (SDefaultCase _) = True 670 | isDefCase _ = False 671 | 672 | getDefExp (SDefaultCase e) = Just e 673 | getDefExp _ = Nothing 674 | 675 | cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) 676 | cgPrimCase caseValPtr defExp alts = do 677 | let caseTy = case head alts of 678 | SConstCase (TT.I _) _ -> IntegerType 32 679 | SConstCase (TT.B8 _) _ -> IntegerType 8 680 | SConstCase (TT.B16 _) _ -> IntegerType 16 681 | SConstCase (TT.B32 _) _ -> IntegerType 32 682 | SConstCase (TT.B64 _) _ -> IntegerType 64 683 | SConstCase (TT.Fl _) _ -> f64 684 | SConstCase (TT.Ch _) _ -> IntegerType 32 685 | realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) [] 686 | valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] 687 | caseVal <- inst $ Load False valPtr Nothing 0 [] 688 | defBlockName <- getName "default" 689 | exitBlockName <- getName "caseExit" 690 | namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts 691 | terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) [] 692 | initEnv <- gets lexenv 693 | defResult <- cgDefaultAlt exitBlockName defBlockName defExp 694 | results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp 695 | finishCase initEnv exitBlockName (defResult:results) 696 | 697 | cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) 698 | cgConCase con defExp alts = do 699 | tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] 700 | tag <- inst $ Load False tagPtr Nothing 0 [] 701 | defBlockName <- getName "default" 702 | exitBlockName <- getName "caseExit" 703 | namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts 704 | terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) -> 705 | (C.Int 32 (fromIntegral tag), n)) namedAlts) [] 706 | initEnv <- gets lexenv 707 | defResult <- cgDefaultAlt exitBlockName defBlockName defExp 708 | results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) -> 709 | cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp 710 | finishCase initEnv exitBlockName (defResult:results) 711 | 712 | cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand) 713 | cgChainCase caseValPtr defExp alts = do 714 | let (caseTy, comparator) = 715 | case head alts of 716 | SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp") 717 | SConstCase (TT.Str _) _ -> (FString, "strcmp") 718 | caseVal <- unbox caseTy caseValPtr 719 | defBlockName <- getName "default" 720 | exitBlockName <- getName "caseExit" 721 | namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts 722 | initEnv <- gets lexenv 723 | results <- forM namedAlts $ \(name, SConstCase c e) -> 724 | do const <- unbox caseTy =<< cgConst c 725 | cmp <- inst $ simpleCall comparator [const, caseVal] 726 | cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] 727 | elseName <- getName "else" 728 | terminate $ CondBr cmpResult name elseName [] 729 | result <- cgAlt initEnv exitBlockName name Nothing e 730 | newBlock elseName 731 | return result 732 | modify $ \s -> s { lexenv = initEnv } 733 | fname <- getFuncName 734 | defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp) 735 | defaultBlock <- gets currentBlockName 736 | defaultEnv <- gets lexenv 737 | defResult <- case defaultVal of 738 | Just v -> do 739 | terminate $ Br exitBlockName [] 740 | return $ Just (v, defaultBlock, defaultEnv) 741 | Nothing -> do 742 | terminate $ Unreachable [] 743 | return Nothing 744 | finishCase initEnv exitBlockName (defResult:results) 745 | 746 | finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand) 747 | finishCase initEnv exitBlockName results = do 748 | let definedResults = mapMaybe id results 749 | case definedResults of 750 | [] -> do modify $ \s -> s { lexenv = initEnv } 751 | return Nothing 752 | xs -> do 753 | newBlock exitBlockName 754 | mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs 755 | Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) 756 | (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) []) 757 | 758 | 759 | cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env)) 760 | cgDefaultAlt exitName name exp = do 761 | newBlock name 762 | fname <- getFuncName 763 | val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp) 764 | env <- gets lexenv 765 | block <- gets currentBlockName 766 | case val of 767 | Just v -> 768 | do terminate $ Br exitName [] 769 | return $ Just (v, block, env) 770 | Nothing -> 771 | do terminate $ Unreachable [] 772 | return Nothing 773 | 774 | cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp 775 | -> Codegen (Maybe (Operand, Name, Env)) 776 | cgAlt initEnv exitBlockName name destr exp = do 777 | modify $ \s -> s { lexenv = initEnv } 778 | newBlock name 779 | locals <- case destr of 780 | Nothing -> return [] 781 | Just (con, argns) -> 782 | forM (zip argns [0..]) $ \(argName, i) -> 783 | do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0) 784 | , ConstantOperand (C.Int 32 1) 785 | , ConstantOperand (C.Int 32 i)] [] 786 | Just <$> ninst argName (Load False ptr Nothing 0 []) 787 | altVal <- binds locals $ cgExpr exp 788 | altEnv <- gets lexenv 789 | altBlock <- gets currentBlockName 790 | case altVal of 791 | Just v -> do 792 | terminate $ Br exitBlockName [] 793 | return $ Just (v, altBlock, altEnv) 794 | Nothing -> do 795 | terminate $ Unreachable [] 796 | return Nothing 797 | 798 | mergeEnvs :: [(Name, Env)] -> Codegen () 799 | mergeEnvs es = do 800 | let vars = transpose 801 | . map (\(block, env) -> map (\x -> (x, block)) env) 802 | $ es 803 | env <- forM vars $ \var -> 804 | case var of 805 | [] -> ierror "mergeEnvs: impossible" 806 | [(v, _)] -> return v 807 | vs@((v, _):_) 808 | | all (== v) (map fst vs) -> return v 809 | | otherwise -> 810 | let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in 811 | Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid []) 812 | modify $ \s -> s { lexenv = env } 813 | 814 | nameAlt :: Name -> SAlt -> Codegen Name 815 | nameAlt d (SDefaultCase _) = return d 816 | nameAlt _ (SConCase _ _ name _ _) = getName (show name) 817 | nameAlt _ (SConstCase const _) = getName (show const) 818 | 819 | isHeapFTy :: FType -> Bool 820 | isHeapFTy f = elem f [FString, FPtr, FAny, FArith (ATInt ITBig)] 821 | 822 | box :: FType -> Operand -> Codegen Operand 823 | box FUnit _ = return $ ConstantOperand nullValue 824 | box fty fval = do 825 | let ty = primTy (ftyToTy fty) 826 | val <- if isHeapFTy fty then alloc ty else allocAtomic ty 827 | tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] [] 828 | valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] [] 829 | inst' $ Store False tagptr (ci32 (-1)) Nothing 0 [] 830 | inst' $ Store False valptr fval Nothing 0 [] 831 | p <- inst $ BitCast val ptrI8 [] 832 | inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), p] 833 | inst $ BitCast val (PointerType valueType (AddrSpace 0)) [] 834 | 835 | unbox :: FType -> Operand -> Codegen Operand 836 | unbox FUnit x = return x 837 | unbox fty bval = do 838 | val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) [] 839 | fvalptr <- inst $ GetElementPtr True val [ci32 0, ci32 1] [] 840 | inst $ Load False fvalptr Nothing 0 [] 841 | 842 | 843 | 844 | cgConst' :: TT.Const -> C.Constant 845 | cgConst' (TT.I i) = C.Int 32 (fromIntegral i) 846 | cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i) 847 | cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i) 848 | cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i) 849 | cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i) 850 | 851 | cgConst' (TT.BI i) = C.Array i8 (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0]) 852 | cgConst' (TT.Fl f) = C.Float (F.Double f) 853 | cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c 854 | cgConst' (TT.Str s) = C.Array i8 (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0]) 855 | cgConst' x = ierror $ "Unsupported constant: " ++ show x 856 | 857 | cgConst :: TT.Const -> Codegen Operand 858 | cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c) 859 | cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c) 860 | cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c) 861 | cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c) 862 | cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c) 863 | 864 | cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c) 865 | cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c) 866 | cgConst c@(TT.Str s) = do 867 | str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c) 868 | box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0]) 869 | cgConst c@(TT.BI i) = do 870 | let stringRepLen = (if i < 0 then 2 else 1) + fromInteger (numDigits 10 i) 871 | str <- addGlobal' (ArrayType stringRepLen (IntegerType 8)) (cgConst' c) 872 | mpz <- alloc mpzTy 873 | inst $ simpleCall "__gmpz_init_set_str" [mpz 874 | , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0] 875 | , ConstantOperand $ C.Int 32 10 876 | ] 877 | box (FArith (ATInt ITBig)) mpz 878 | cgConst x = return $ ConstantOperand nullValue 879 | 880 | numDigits :: Integer -> Integer -> Integer 881 | numDigits b n = 1 + fst (ilog b (abs n)) where 882 | ilog b n 883 | | n < b = (0, n) 884 | | otherwise = let (e, r) = ilog (b*b) n 885 | in if r < b then (2*e, r) else (2*e+1, r `div` b) 886 | 887 | addGlobal :: Global -> Codegen () 888 | addGlobal def = tell ([], [], [GlobalDefinition def]) 889 | 890 | addGlobal' :: Type -> C.Constant -> Codegen C.Constant 891 | addGlobal' ty val = do 892 | name <- getGlobalUnName 893 | addGlobal $ globalVariableDefaults 894 | { G.name = name 895 | , G.linkage = L.Internal 896 | , G.unnamedAddr = Just G.GlobalAddr 897 | , G.isConstant = True 898 | , G.type' = ty 899 | , G.initializer = Just val 900 | } 901 | return $ C.GlobalReference ty name 902 | 903 | 904 | ensureCDecl :: String -> FType -> [FType] -> Codegen Operand 905 | ensureCDecl name rty argtys = do 906 | syms <- gets foreignSyms 907 | case M.lookup name syms of 908 | Nothing -> do addGlobal (ffunDecl name rty argtys) 909 | modify $ \s -> s { foreignSyms = M.insert name (rty, argtys) (foreignSyms s) } 910 | Just (rty', argtys') -> unless (rty == rty' && argtys == argtys') . fail $ 911 | "Mismatched type declarations for foreign symbol \"" ++ name ++ "\": " ++ show (rty, argtys) ++ " vs " ++ show (rty', argtys') 912 | return $ globalRef name 913 | 914 | ffunDecl :: String -> FType -> [FType] -> Global 915 | ffunDecl name rty argtys = 916 | functionDefaults 917 | { G.returnType = ftyToTy rty 918 | , G.name = mkName name 919 | , G.parameters = (flip map argtys $ \fty -> 920 | Parameter (ftyToTy fty) (UnName 0) [] 921 | , False) 922 | } 923 | 924 | ftyToTy :: FType -> Type 925 | ftyToTy (FArith (ATInt ITNative)) = i32 926 | ftyToTy (FArith (ATInt ITBig)) = ptr mpzTy 927 | ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty) 928 | ftyToTy (FArith (ATInt ITChar)) = i32 929 | ftyToTy (FArith ATFloat) = f64 930 | ftyToTy FString = ptrI8 931 | ftyToTy FUnit = VoidType 932 | ftyToTy FPtr = ptrI8 933 | ftyToTy FManagedPtr = ptrI8 934 | ftyToTy FCData = ptrI8 935 | ftyToTy FFunction = error "hello" 936 | ftyToTy FFunctionIO = error "hello" 937 | ftyToTy FAny = valueType 938 | 939 | -- Only use when known not to be ITBig 940 | itWidth :: IntTy -> Word32 941 | itWidth ITNative = 32 942 | itWidth ITChar = 32 943 | itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x 944 | itWidth x = ierror $ "itWidth: " ++ show x 945 | 946 | itConst :: IntTy -> Integer -> C.Constant 947 | itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x 948 | itConst ITNative x = itConst (ITFixed IT32) x 949 | itConst ITChar x = itConst (ITFixed IT32) x 950 | 951 | cgOp :: PrimFn -> [Operand] -> Codegen Operand 952 | cgOp (LTrunc ITBig ity) [x] = do 953 | nx <- unbox (FArith (ATInt ITBig)) x 954 | val <- inst $ simpleCall "mpz_get_ull" [nx] 955 | v <- case ity of 956 | (ITFixed IT64) -> return val 957 | _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) [] 958 | box (FArith (ATInt ity)) v 959 | cgOp (LZExt from ITBig) [x] = do 960 | nx <- unbox (FArith (ATInt from)) x 961 | nx' <- case from of 962 | (ITFixed IT64) -> return nx 963 | _ -> inst $ ZExt nx (IntegerType 64) [] 964 | mpz <- alloc mpzTy 965 | inst' $ simpleCall "mpz_init_set_ull" [mpz, nx'] 966 | box (FArith (ATInt ITBig)) mpz 967 | cgOp (LSExt from ITBig) [x] = do 968 | nx <- unbox (FArith (ATInt from)) x 969 | nx' <- case from of 970 | (ITFixed IT64) -> return nx 971 | _ -> inst $ SExt nx (IntegerType 64) [] 972 | mpz <- alloc mpzTy 973 | inst' $ simpleCall "mpz_init_set_sll" [mpz, nx'] 974 | box (FArith (ATInt ITBig)) mpz 975 | 976 | -- ITChar, ITNative, and IT32 all share representation 977 | cgOp (LChInt ITNative) [x] = return x 978 | cgOp (LIntCh ITNative) [x] = return x 979 | 980 | cgOp (LSLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y 981 | cgOp (LSLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y 982 | cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y 983 | cgOp (LSGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y 984 | cgOp (LSGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y 985 | cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y 986 | cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y 987 | cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y 988 | cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y 989 | cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y 990 | cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y 991 | cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y 992 | cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y 993 | cgOp (LCompl ITBig) [x] = mpzUn "com" x 994 | cgOp (LSHL ITBig) [x,y] = mpzBit "mul_2exp" x y 995 | cgOp (LASHR ITBig) [x,y] = mpzBit "fdiv_q_2exp" x y 996 | 997 | cgOp (LTrunc ITNative (ITFixed to)) [x] 998 | | 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x 999 | cgOp (LZExt ITNative (ITFixed to)) [x] 1000 | | 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x 1001 | cgOp (LSExt ITNative (ITFixed to)) [x] 1002 | | 32 <= nativeTyWidth to = iCoerce SExt IT32 to x 1003 | 1004 | cgOp (LTrunc (ITFixed from) ITNative) [x] 1005 | | nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x 1006 | cgOp (LZExt (ITFixed from) ITNative) [x] 1007 | | nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x 1008 | cgOp (LSExt (ITFixed from) ITNative) [x] 1009 | | nativeTyWidth from <= 32 = iCoerce SExt from IT32 x 1010 | 1011 | cgOp (LTrunc (ITFixed from) (ITFixed to)) [x] 1012 | | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x 1013 | cgOp (LZExt (ITFixed from) (ITFixed to)) [x] 1014 | | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x 1015 | cgOp (LSExt (ITFixed from) (ITFixed to)) [x] 1016 | | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x 1017 | 1018 | cgOp (LSLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y 1019 | cgOp (LSLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y 1020 | cgOp (LLt ity) [x,y] = iCmp ity IPred.ULT x y 1021 | cgOp (LLe ity) [x,y] = iCmp ity IPred.ULE x y 1022 | cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y 1023 | cgOp (LSGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y 1024 | cgOp (LSGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y 1025 | cgOp (LGe ity) [x,y] = iCmp ity IPred.UGE x y 1026 | cgOp (LGt ity) [x,y] = iCmp ity IPred.UGT x y 1027 | cgOp (LPlus ty@(ATInt _)) [x,y] = binary ty x y (Add False False) 1028 | cgOp (LMinus ty@(ATInt _)) [x,y] = binary ty x y (Sub False False) 1029 | cgOp (LTimes ty@(ATInt _)) [x,y] = binary ty x y (Mul False False) 1030 | cgOp (LSDiv ty@(ATInt _)) [x,y] = binary ty x y (SDiv False) 1031 | cgOp (LSRem ty@(ATInt _)) [x,y] = binary ty x y SRem 1032 | cgOp (LUDiv ity) [x,y] = binary (ATInt ity) x y (UDiv False) 1033 | cgOp (LURem ity) [x,y] = binary (ATInt ity) x y URem 1034 | cgOp (LAnd ity) [x,y] = binary (ATInt ity) x y And 1035 | cgOp (LOr ity) [x,y] = binary (ATInt ity) x y Or 1036 | cgOp (LXOr ity) [x,y] = binary (ATInt ity) x y Xor 1037 | cgOp (LCompl ity) [x] = unary (ATInt ity) x (Xor . ConstantOperand $ itConst ity (-1)) 1038 | cgOp (LSHL ity) [x,y] = binary (ATInt ity) x y (Shl False False) 1039 | cgOp (LLSHR ity) [x,y] = binary (ATInt ity) x y (LShr False) 1040 | cgOp (LASHR ity) [x,y] = binary (ATInt ity) x y (AShr False) 1041 | 1042 | cgOp (LSLt ATFloat) [x,y] = fCmp FPred.OLT x y 1043 | cgOp (LSLe ATFloat) [x,y] = fCmp FPred.OLE x y 1044 | cgOp (LEq ATFloat) [x,y] = fCmp FPred.OEQ x y 1045 | cgOp (LSGe ATFloat) [x,y] = fCmp FPred.OGE x y 1046 | cgOp (LSGt ATFloat) [x,y] = fCmp FPred.OGT x y 1047 | cgOp (LPlus ATFloat) [x,y] = binary ATFloat x y (FAdd NoFastMathFlags) 1048 | cgOp (LMinus ATFloat) [x,y] = binary ATFloat x y (FSub NoFastMathFlags) 1049 | cgOp (LTimes ATFloat) [x,y] = binary ATFloat x y (FMul NoFastMathFlags) 1050 | cgOp (LSDiv ATFloat) [x,y] = binary ATFloat x y (FDiv NoFastMathFlags) 1051 | 1052 | cgOp LFExp [x] = nunary ATFloat "llvm.exp.f64" x 1053 | cgOp LFLog [x] = nunary ATFloat "llvm.log.f64" x 1054 | cgOp LFSin [x] = nunary ATFloat "llvm.sin.f64" x 1055 | cgOp LFCos [x] = nunary ATFloat "llvm.cos.f64" x 1056 | cgOp LFTan [x] = nunary ATFloat "tan" x 1057 | cgOp LFASin [x] = nunary ATFloat "asin" x 1058 | cgOp LFACos [x] = nunary ATFloat "acos" x 1059 | cgOp LFATan [x] = nunary ATFloat "atan" x 1060 | cgOp LFSqrt [x] = nunary ATFloat "llvm.sqrt.f64" x 1061 | cgOp LFFloor [x] = nunary ATFloat "llvm.floor.f64" x 1062 | cgOp LFCeil [x] = nunary ATFloat "llvm.ceil.f64" x 1063 | cgOp LFNegate [x] = do 1064 | z <- box (FArith ATFloat) (ConstantOperand $ C.Float $ F.Double (-0.0)) 1065 | binary ATFloat z x (FSub NoFastMathFlags) 1066 | 1067 | cgOp (LIntFloat ITBig) [x] = do 1068 | x' <- unbox (FArith (ATInt ITBig)) x 1069 | uflt <- inst $ simpleCall "__gmpz_get_d" [ x' ] 1070 | box (FArith ATFloat) uflt 1071 | 1072 | cgOp (LIntFloat ity) [x] = do 1073 | x' <- unbox (FArith (ATInt ity)) x 1074 | x'' <- inst $ SIToFP x' (f64) [] 1075 | box (FArith ATFloat) x'' 1076 | 1077 | cgOp (LFloatInt ITBig) [x] = do 1078 | x' <- unbox (FArith ATFloat) x 1079 | z <- alloc mpzTy 1080 | inst' $ simpleCall "__gmpz_init" [z] 1081 | inst' $ simpleCall "__gmpz_set_d" [ z, x' ] 1082 | box (FArith (ATInt ITBig)) z 1083 | 1084 | cgOp (LFloatInt ity) [x] = do 1085 | x' <- unbox (FArith ATFloat) x 1086 | x'' <- inst $ FPToSI x' (ftyToTy $ cmpResultTy ity) [] 1087 | box (FArith (ATInt ity)) x'' 1088 | 1089 | cgOp LFloatStr [x] = do 1090 | x' <- unbox (FArith ATFloat) x 1091 | ustr <- inst (idrCall "__idris_floatStr" [x']) 1092 | box FString ustr 1093 | 1094 | cgOp LStrFloat [s] = do 1095 | ns <- unbox FString s 1096 | nx <- inst $ simpleCall "strtod" 1097 | [ns 1098 | , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) 1099 | ] 1100 | box (FArith ATFloat) nx 1101 | 1102 | cgOp LNoOp xs = return $ last xs 1103 | 1104 | 1105 | cgOp (LBitCast from to) [x] = do 1106 | nx <- unbox (FArith from) x 1107 | nx' <- inst $ BitCast nx (ftyToTy (FArith to)) [] 1108 | box (FArith to) nx' 1109 | 1110 | cgOp LStrEq [x,y] = do 1111 | x' <- unbox FString x 1112 | y' <- unbox FString y 1113 | cmp <- inst $ simpleCall "strcmp" [x', y'] 1114 | flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) [] 1115 | val <- inst $ ZExt flag (IntegerType 32) [] 1116 | box (FArith (ATInt (ITFixed IT32))) val 1117 | 1118 | cgOp LStrLt [x,y] = do 1119 | nx <- unbox FString x 1120 | ny <- unbox FString y 1121 | cmp <- inst $ simpleCall "strcmp" [nx, ny] 1122 | flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) [] 1123 | val <- inst $ ZExt flag (IntegerType 32) [] 1124 | box (FArith (ATInt (ITFixed IT32))) val 1125 | 1126 | cgOp (LIntStr ITBig) [x] = do 1127 | x' <- unbox (FArith (ATInt ITBig)) x 1128 | ustr <- inst $ simpleCall "__gmpz_get_str" 1129 | [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0))) 1130 | , ConstantOperand (C.Int 32 10) 1131 | , x' 1132 | ] 1133 | box FString ustr 1134 | cgOp (LIntStr ity) [x] = do 1135 | x' <- unbox (FArith (ATInt ity)) x 1136 | x'' <- if itWidth ity < 64 1137 | then inst $ SExt x' (IntegerType 64) [] 1138 | else return x' 1139 | box FString =<< inst (idrCall "__idris_intStr" [x'']) 1140 | cgOp (LStrInt ITBig) [s] = do 1141 | ns <- unbox FString s 1142 | mpz <- alloc mpzTy 1143 | inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10] 1144 | box (FArith (ATInt ITBig)) mpz 1145 | cgOp (LStrInt ity) [s] = do 1146 | ns <- unbox FString s 1147 | nx <- inst $ simpleCall "strtoll" 1148 | [ns 1149 | , ConstantOperand $ C.Null ppI8 1150 | , ConstantOperand $ C.Int 32 10 1151 | ] 1152 | nx' <- case ity of 1153 | (ITFixed IT64) -> return nx 1154 | _ -> inst $ Trunc nx (IntegerType (itWidth ity)) [] 1155 | box (FArith (ATInt ity)) nx' 1156 | 1157 | cgOp LStrConcat [x,y] = cgStrCat x y 1158 | 1159 | cgOp LStrCons [c,s] = do 1160 | nc <- unbox (FArith (ATInt ITChar)) c 1161 | ns <- unbox FString s 1162 | nc' <- inst $ Trunc nc (IntegerType 8) [] 1163 | r <- inst $ simpleCall "__idris_strCons" [nc', ns] 1164 | box FString r 1165 | 1166 | cgOp LStrHead [c] = do 1167 | s <- unbox FString c 1168 | c <- inst $ Load False s Nothing 0 [] 1169 | c' <- inst $ ZExt c (IntegerType 32) [] 1170 | box (FArith (ATInt ITChar)) c' 1171 | 1172 | cgOp LStrIndex [s, i] = do 1173 | ns <- unbox FString s 1174 | ni <- unbox (FArith (ATInt (ITFixed IT32))) i 1175 | p <- inst $ GetElementPtr True ns [ni] [] 1176 | c <- inst $ Load False p Nothing 0 [] 1177 | c' <- inst $ ZExt c (IntegerType 32) [] 1178 | box (FArith (ATInt ITChar)) c' 1179 | 1180 | cgOp LStrTail [c] = do 1181 | s <- unbox FString c 1182 | c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] [] 1183 | box FString c 1184 | 1185 | cgOp LStrLen [s] = do 1186 | ns <- unbox FString s 1187 | len <- inst $ simpleCall "strlen" [ns] 1188 | ws <- getWordSize 1189 | len' <- case ws of 1190 | 32 -> return len 1191 | x | x > 32 -> inst $ Trunc len (IntegerType 32) [] 1192 | | x < 32 -> inst $ ZExt len (IntegerType 32) [] 1193 | box (FArith (ATInt (ITFixed IT32))) len' 1194 | 1195 | cgOp LStrRev [s] = do 1196 | ns <- unbox FString s 1197 | box FString =<< inst (simpleCall "__idris_strRev" [ns]) 1198 | 1199 | cgOp LStrSubstr [x, y, z] = ignore 1200 | 1201 | cgOp LReadStr [_] = do 1202 | np <- inst $ simpleCall "__idris_stdin" [] 1203 | s <- inst $ simpleCall "__idris_readStr" [np] 1204 | box FString s 1205 | 1206 | cgOp LWriteStr [_,p] = do 1207 | np <- unbox FPtr p 1208 | s <- inst $ simpleCall "printf" [np] 1209 | box (FArith (ATInt ITNative)) s 1210 | 1211 | 1212 | cgOp LSystemInfo [x] = ignore 1213 | cgOp LCrash [x] = ignore 1214 | cgOp LFork [x] = ignore 1215 | cgOp LPar [x] = ignore 1216 | 1217 | -- TODO: ignored primitives, fill in 1218 | 1219 | cgOp (LExternal pr) [_, x] | pr == sUN "prim__readFile" = do 1220 | sp <- unbox FPtr x 1221 | s <- inst $ simpleCall "__idris_readStr" [sp] 1222 | box FString s 1223 | 1224 | cgOp (LExternal pr) [_,len,x] | pr == sUN "prim__readChars" = do 1225 | l <- unbox (FArith (ATInt ITNative)) len 1226 | sp <- unbox FPtr x 1227 | s <- inst $ simpleCall "__idris_readChars" [l, sp] 1228 | box FString s 1229 | 1230 | cgOp (LExternal pr) [_, x, s] | pr == sUN "prim__writeFile" = do 1231 | f <- unbox FPtr x 1232 | sp <- unbox FString s 1233 | i <- inst $ simpleCall "__idris_writeStr" [f, sp] 1234 | box (FArith (ATInt ITNative)) i 1235 | 1236 | cgOp (LExternal pr) [] | pr == sUN "prim__stdin" = do 1237 | i <- inst $ simpleCall "__idris_stdin" [] 1238 | box FPtr i 1239 | cgOp (LExternal pr) [] | pr == sUN "prim__stdout" = do 1240 | i <- inst $ simpleCall "__idris_stdout" [] 1241 | box FPtr i 1242 | cgOp (LExternal pr) [] | pr == sUN "prim__stderr" = do 1243 | i <- inst $ simpleCall "__idris_stdout" [] 1244 | box FPtr i 1245 | 1246 | cgOp (LExternal pr) [p] | pr == sUN "prim__asPtr" = do 1247 | sp <- unbox FManagedPtr p 1248 | s <- inst $ simpleCall "__idris_getRegisteredPtr" [sp] 1249 | box FPtr s 1250 | 1251 | cgOp (LExternal pr) [] | pr == sUN "prim__null" = box FPtr (ConstantOperand $ C.Null ptrI8) 1252 | 1253 | cgOp (LExternal pr) [_] | pr == sUN "prim__vm" = ignore 1254 | cgOp (LExternal pr) [x, y] | pr == sUN "prim__eqPtr" = ptrEq x y 1255 | cgOp (LExternal pr) [x, y] | pr == sUN "prim__eqManagedPtr" = do 1256 | a <- unbox FPtr x 1257 | b <- unbox FPtr y 1258 | c <- inst $ Load False a Nothing 0 [] 1259 | d <- inst $ Load False b Nothing 0 [] 1260 | e <- inst $ ICmp IPred.EQ c d [] 1261 | r <- inst $ SExt e i32 [] 1262 | box (FArith (ATInt ITNative)) r 1263 | 1264 | cgOp (LExternal pr) [p, i] | pr == sUN "prim__registerPtr" = do 1265 | l <- unbox (FArith (ATInt ITNative)) i 1266 | sp <- unbox FPtr p 1267 | s <- inst $ simpleCall "__idris_registerPtr" [sp, l] 1268 | box FManagedPtr s 1269 | 1270 | 1271 | cgOp (LExternal pr) [_, p, o] | pr == sUN "prim__peek8" = peek (FArith (ATInt (ITFixed IT8))) p o 1272 | cgOp (LExternal pr) [_, p, o, x] | pr == sUN "prim__poke8" = poke (FArith (ATInt (ITFixed IT8))) p o x 1273 | 1274 | cgOp (LExternal pr) [_, p, o] | pr == sUN "prim__peek16" = peek (FArith (ATInt (ITFixed IT16))) p o 1275 | cgOp (LExternal pr) [_, p, o, x] | pr == sUN "prim__poke16" = poke (FArith (ATInt (ITFixed IT16))) p o x 1276 | cgOp (LExternal pr) [_, p, o] | pr == sUN "prim__peek32" = peek (FArith (ATInt (ITFixed IT32))) p o 1277 | cgOp (LExternal pr) [_, p, o, x] | pr == sUN "prim__poke32" = poke (FArith (ATInt (ITFixed IT32))) p o x 1278 | cgOp (LExternal pr) [_, p, o] | pr == sUN "prim__peek64" = peek (FArith (ATInt (ITFixed IT64))) p o 1279 | cgOp (LExternal pr) [_, p, o, x] | pr == sUN "prim__poke64" = poke (FArith (ATInt (ITFixed IT64))) p o x 1280 | 1281 | cgOp (LExternal pr) [_, p, o] | pr == sUN "prim__peekPtr" = peek FPtr p o 1282 | cgOp (LExternal pr) [_, p, o, x] | pr == sUN "prim__pokePtr" = poke FPtr p o x 1283 | 1284 | cgOp (LExternal pr) [_, p, o] | pr == sUN "prim__peekDouble" = peek (FArith ATFloat) p o 1285 | cgOp (LExternal pr) [_, p, o, x] | pr == sUN "prim__pokeDouble" = poke (FArith ATFloat) p o x 1286 | 1287 | cgOp (LExternal pr) [_, p, o] | pr == sUN "prim__peekSingle" = peekSingle p o 1288 | cgOp (LExternal pr) [_, p, o, x] | pr == sUN "prim__pokeSingle" = pokeSingle p o x 1289 | 1290 | cgOp (LExternal pr) [p, n] | pr == sUN "prim__ptrOffset" = do 1291 | pt <- unbox FPtr p 1292 | o <- unbox (FArith (ATInt ITNative)) n 1293 | ws <- getWordSize 1294 | offz <- inst $ ZExt o (IntegerType ws) [] 1295 | i <- inst $ PtrToInt pt (IntegerType ws) [] 1296 | offi <- inst $ Add False True i offz [] 1297 | offp <- inst $ IntToPtr offi ptrI8 [] 1298 | box FPtr offp 1299 | 1300 | cgOp (LExternal pr) [] | pr == sUN "prim__sizeofPtr" = do 1301 | i <- inst $ simpleCall "__idris_sizeofPtr" [] 1302 | box (FArith (ATInt ITNative)) i 1303 | 1304 | cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">(" 1305 | ++ intersperse ',' (take (length args) ['a'..]) ++ ")" 1306 | 1307 | 1308 | ignore = return $ ConstantOperand nullValue 1309 | iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand 1310 | iCoerce _ from to x | from == to = return x 1311 | iCoerce operator from to x = do 1312 | x' <- unbox (FArith (ATInt (ITFixed from))) x 1313 | x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed to)))) [] 1314 | box (FArith (ATInt (ITFixed to))) x'' 1315 | 1316 | cgStrCat :: Operand -> Operand -> Codegen Operand 1317 | cgStrCat x y = do 1318 | x' <- unbox FString x 1319 | y' <- unbox FString y 1320 | xlen <- inst $ simpleCall "strlen" [x'] 1321 | ylen <- inst $ simpleCall "strlen" [y'] 1322 | zlen <- inst $ Add False True xlen ylen [] 1323 | ws <- getWordSize 1324 | total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) [] 1325 | mem <- allocAtomic' total 1326 | inst $ simpleCall "memcpy" [mem, x', xlen] 1327 | i <- inst $ PtrToInt mem (IntegerType ws) [] 1328 | offi <- inst $ Add False True i xlen [] 1329 | offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) [] 1330 | inst $ simpleCall "memcpy" [offp, y', ylen] 1331 | j <- inst $ PtrToInt offp (IntegerType ws) [] 1332 | offj <- inst $ Add False True j ylen [] 1333 | end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) [] 1334 | inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 [] 1335 | box FString mem 1336 | 1337 | binary :: ArithTy -> Operand -> Operand 1338 | -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand 1339 | binary ty x y instCon = do 1340 | nx <- unbox (FArith ty) x 1341 | ny <- unbox (FArith ty) y 1342 | nr <- inst $ instCon nx ny [] 1343 | box (FArith ty) nr 1344 | 1345 | unary :: ArithTy -> Operand 1346 | -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand 1347 | unary ty x instCon = do 1348 | nx <- unbox (FArith ty) x 1349 | nr <- inst $ instCon nx [] 1350 | box (FArith ty) nr 1351 | 1352 | nunary :: ArithTy -> String 1353 | -> Operand -> Codegen Operand 1354 | nunary ty name x = do 1355 | nx <- unbox (FArith ty) x 1356 | nr <- inst $ simpleCall name [nx] 1357 | box (FArith ty) nr 1358 | 1359 | iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand 1360 | iCmp ity pred x y = do 1361 | nx <- unbox (FArith (ATInt ity)) x 1362 | ny <- unbox (FArith (ATInt ity)) y 1363 | nr <- inst $ ICmp pred nx ny [] 1364 | nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) [] 1365 | box (cmpResultTy ity) nr' 1366 | 1367 | fCmp :: FPred.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand 1368 | fCmp pred x y = do 1369 | nx <- unbox (FArith ATFloat) x 1370 | ny <- unbox (FArith ATFloat) y 1371 | nr <- inst $ FCmp pred nx ny [] 1372 | box (FArith (ATInt (ITFixed IT32))) nr 1373 | 1374 | cmpResultTy :: IntTy -> FType 1375 | -- cmpResultTy v@(ITVec _ _) = FArith (ATInt v) 1376 | cmpResultTy _ = FArith (ATInt (ITFixed IT32)) 1377 | 1378 | mpzBin :: String -> Operand -> Operand -> Codegen Operand 1379 | mpzBin name x y = do 1380 | nx <- unbox (FArith (ATInt ITBig)) x 1381 | ny <- unbox (FArith (ATInt ITBig)) y 1382 | nz <- alloc mpzTy 1383 | inst' $ simpleCall "__gmpz_init" [nz] 1384 | inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny] 1385 | box (FArith (ATInt ITBig)) nz 1386 | 1387 | mpzBit :: String -> Operand -> Operand -> Codegen Operand 1388 | mpzBit name x y = do 1389 | nx <- unbox (FArith (ATInt ITBig)) x 1390 | ny <- unbox (FArith (ATInt ITBig)) y 1391 | bitcnt <- inst $ simpleCall "__gmpz_get_ui" [ny] 1392 | nz <- alloc mpzTy 1393 | inst' $ simpleCall "__gmpz_init" [nz] 1394 | inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, bitcnt] 1395 | box (FArith (ATInt ITBig)) nz 1396 | 1397 | mpzUn :: String -> Operand -> Codegen Operand 1398 | mpzUn name x = do 1399 | nx <- unbox (FArith (ATInt ITBig)) x 1400 | nz <- alloc mpzTy 1401 | inst' $ simpleCall "__gmpz_init" [nz] 1402 | inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx] 1403 | box (FArith (ATInt ITBig)) nz 1404 | 1405 | mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand 1406 | mpzCmp pred x y = do 1407 | nx <- unbox (FArith (ATInt ITBig)) x 1408 | ny <- unbox (FArith (ATInt ITBig)) y 1409 | cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny] 1410 | result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) [] 1411 | i <- inst $ ZExt result (IntegerType 32) [] 1412 | box (FArith (ATInt (ITFixed IT32))) i 1413 | 1414 | 1415 | ptrEq x y = do 1416 | a <- unbox FPtr x 1417 | b <- unbox FPtr y 1418 | e <- inst $ ICmp IPred.EQ a b [] 1419 | r <- inst $ SExt e i32 [] 1420 | box (FArith (ATInt ITNative)) r 1421 | 1422 | peek t p o = do 1423 | pt <- unbox FPtr p 1424 | off <- unbox (FArith (ATInt ITNative)) o 1425 | ws <- getWordSize 1426 | offz <- inst $ ZExt off (IntegerType ws) [] 1427 | i <- inst $ PtrToInt pt (IntegerType ws) [] 1428 | offi <- inst $ Add False True i offz [] 1429 | offp <- inst $ IntToPtr offi (ptr $ ftyToTy t) [] 1430 | r <- inst $ Load False offp Nothing 0 [] 1431 | box t r 1432 | 1433 | poke t p o x = do 1434 | pt <- unbox FPtr p 1435 | off <- unbox (FArith (ATInt ITNative)) o 1436 | v <- unbox t x 1437 | ws <- getWordSize 1438 | offz <- inst $ ZExt off (IntegerType ws) [] 1439 | i <- inst $ PtrToInt pt (IntegerType ws) [] 1440 | offi <- inst $ Add False True i offz [] 1441 | offp <- inst $ IntToPtr offi (ptr $ ftyToTy t) [] 1442 | inst' $ Store False offp v Nothing 0 [] 1443 | box (FArith (ATInt ITNative)) (ci32 0) 1444 | 1445 | peekSingle p o = do 1446 | pt <- unbox FPtr p 1447 | off <- unbox (FArith (ATInt ITNative)) o 1448 | ws <- getWordSize 1449 | offz <- inst $ ZExt off (IntegerType ws) [] 1450 | i <- inst $ PtrToInt pt (IntegerType ws) [] 1451 | offi <- inst $ Add False True i offz [] 1452 | offp <- inst $ IntToPtr offi (ptr f32) [] 1453 | r <- inst $ Load False offp Nothing 0 [] 1454 | d <- inst $ FPExt r f64 [] 1455 | box (FArith ATFloat) d 1456 | 1457 | pokeSingle p o x = do 1458 | pt <- unbox FPtr p 1459 | off <- unbox (FArith (ATInt ITNative)) o 1460 | v <- unbox (FArith ATFloat) x 1461 | s <- inst $ FPTrunc v f32 [] 1462 | ws <- getWordSize 1463 | offz <- inst $ ZExt off (IntegerType ws) [] 1464 | i <- inst $ PtrToInt pt (IntegerType ws) [] 1465 | offi <- inst $ Add False True i offz [] 1466 | offp <- inst $ IntToPtr offi (ptr $ f32) [] 1467 | inst' $ Store False offp s Nothing 0 [] 1468 | box (FArith (ATInt ITNative)) (ci32 0) 1469 | 1470 | 1471 | 1472 | -- Deconstruct the Foreign type in the defunctionalised expression and build 1473 | -- a foreign type description. 1474 | toAType (FCon i) 1475 | | i == sUN "C_IntChar" = ATInt ITChar 1476 | | i == sUN "C_IntNative" = ATInt ITNative 1477 | | i == sUN "C_IntBits8" = ATInt (ITFixed IT8) 1478 | | i == sUN "C_IntBits16" = ATInt (ITFixed IT16) 1479 | | i == sUN "C_IntBits32" = ATInt (ITFixed IT32) 1480 | | i == sUN "C_IntBits64" = ATInt (ITFixed IT64) 1481 | toAType t = error (show t ++ " not defined in toAType") 1482 | 1483 | toFType (FCon c) 1484 | | c == sUN "C_Str" = FString 1485 | | c == sUN "C_Float" = FArith ATFloat 1486 | | c == sUN "C_Ptr" = FPtr 1487 | | c == sUN "C_MPtr" = FManagedPtr 1488 | | c == sUN "C_CData" = FCData 1489 | | c == sUN "C_Unit" = FUnit 1490 | toFType (FApp c [_,ity]) 1491 | | c == sUN "C_IntT" = FArith (toAType ity) 1492 | | c == sUN "C_FnT" = toFunType ity 1493 | toFType (FApp c [_]) 1494 | | c == sUN "C_Any" = FAny 1495 | toFType t = FAny 1496 | 1497 | toFunType (FApp c [_,ity]) 1498 | | c == sUN "C_FnBase" = FFunction 1499 | | c == sUN "C_FnIO" = FFunctionIO 1500 | toFunType (FApp c [_,_,_,ity]) 1501 | | c == sUN "C_Fn" = toFunType ity 1502 | toFunType _ = FAny 1503 | 1504 | simpleCall :: String -> [Operand] -> Instruction 1505 | simpleCall name args = 1506 | Call { tailCallKind = Nothing 1507 | , callingConvention = CC.C 1508 | , returnAttributes = [] 1509 | , function = Right $ globalRef name 1510 | , arguments = map (\x -> (x, [])) args 1511 | , functionAttributes = [] 1512 | , metadata = [] 1513 | } 1514 | 1515 | idrCall :: String -> [Operand] -> Instruction 1516 | idrCall name args = 1517 | Call { tailCallKind = Nothing 1518 | , callingConvention = CC.Fast 1519 | , returnAttributes = [] 1520 | , function = Right $ globalRef name 1521 | , arguments = map (\x -> (x, [])) args 1522 | , functionAttributes = [] 1523 | , metadata = [] 1524 | } 1525 | 1526 | assert :: Operand -> String -> Codegen () 1527 | assert condition message = do 1528 | passed <- getName "assertPassed" 1529 | failed <- getName "assertFailed" 1530 | terminate $ CondBr condition passed failed [] 1531 | newBlock failed 1532 | cgExpr (SError message) 1533 | terminate $ Unreachable [] 1534 | newBlock passed 1535 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Idris.Core.TT 4 | import Idris.AbsSyntax 5 | import Idris.ElabDecls 6 | import Idris.Main 7 | import Idris.Options 8 | import Idris.REPL 9 | 10 | import Paths_idris_llvm 11 | 12 | import IRTS.Compiler 13 | import IRTS.CodegenLLVM 14 | import qualified IRTS.CodegenCommon as CG 15 | 16 | import LLVM.Target 17 | import System.Environment 18 | import System.Exit 19 | 20 | data Opts = Opts { inputs :: [FilePath], 21 | output :: FilePath, 22 | outputType :: CG.OutputType, 23 | oTargetTriple :: String, 24 | oTargetCPU :: String } 25 | 26 | showUsage = do putStrLn "Usage: idris-llvm [-o ]" 27 | exitWith ExitSuccess 28 | 29 | getOpts :: IO Opts 30 | getOpts = do xs <- getArgs 31 | return $ process (Opts [] "a.out" CG.Executable "" "") xs 32 | where 33 | process opts ("-o":o:xs) = process (opts { output = o }) xs 34 | process opts ("-S":xs) = process (opts { outputType = CG.Raw }) xs 35 | process opts ("-c":xs) = process (opts { outputType = CG.Object }) xs 36 | process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs 37 | process opts [] = opts 38 | 39 | llvm_main :: Opts -> Idris () 40 | llvm_main opts = do elabPrims 41 | loadInputs (inputs opts) Nothing 42 | mainProg <- elabMain 43 | ir <- compile (Via IBCFormat "llvm") (output opts) (Just mainProg) 44 | runIO $ codegenLLVM (ir { 45 | CG.targetTriple = oTargetTriple opts, 46 | CG.targetCPU = oTargetCPU opts, 47 | CG.outputType = outputType opts } ) 48 | 49 | main :: IO () 50 | main = do opts <- getOpts 51 | if (null (inputs opts)) 52 | then showUsage 53 | else runMain (llvm_main opts) 54 | 55 | -------------------------------------------------------------------------------- /src/rts/Makefile: -------------------------------------------------------------------------------- 1 | include ../../config.mk 2 | 3 | CFLAGS:=-Wextra -fPIC -Wno-unused-parameter $(CFLAGS) 4 | SOURCES=defs.c getline.c idris_buffer.c 5 | OBJECTS=$(SOURCES:.c=.o) 6 | LIB=libidris_rts.a 7 | 8 | build: $(SOURCES) $(LIB) 9 | 10 | $(LIB): $(OBJECTS) 11 | ar r $@ $(OBJECTS) 12 | ranlib $@ 13 | 14 | .c.o: 15 | $(CC) -c $(CFLAGS) $< -o $@ 16 | 17 | install: $(LIB) 18 | mkdir -p $(TARGET) 19 | install $(LIB) $(TARGET) 20 | 21 | clean: 22 | rm -f $(OBJECTS) $(LIB) 23 | 24 | .PHONY: build install clean 25 | -------------------------------------------------------------------------------- /src/rts/defs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include "getline.h" 9 | #include "rts.h" 10 | 11 | extern char** environ; 12 | 13 | void putStr(const char *str) { 14 | fputs(str, stdout); 15 | } 16 | 17 | void putErr(const char *str) { 18 | fputs(str, stderr); 19 | } 20 | 21 | // Get zeroed memory 22 | static void* alloc(size_t s) { 23 | void* mem = GC_malloc(s); 24 | memset(mem, 0, s); 25 | return mem; 26 | } 27 | 28 | void mpz_init_set_ull(mpz_t n, unsigned long long ull) 29 | { 30 | mpz_init_set_ui(n, (unsigned int)(ull >> 32)); /* n = (unsigned int)(ull >> 32) */ 31 | mpz_mul_2exp(n, n, 32); /* n <<= 32 */ 32 | mpz_add_ui(n, n, (unsigned int)ull); /* n += (unsigned int)ull */ 33 | } 34 | 35 | void mpz_init_set_sll(mpz_t n, long long sll) 36 | { 37 | mpz_init_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */ 38 | mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */ 39 | mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */ 40 | } 41 | 42 | void mpz_set_sll(mpz_t n, long long sll) 43 | { 44 | mpz_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */ 45 | mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */ 46 | mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */ 47 | } 48 | 49 | unsigned long long mpz_get_ull(mpz_t n) 50 | { 51 | unsigned int lo, hi; 52 | mpz_t tmp; 53 | 54 | mpz_init( tmp ); 55 | mpz_mod_2exp( tmp, n, 64 ); /* tmp = (lower 64 bits of n) */ 56 | 57 | lo = mpz_get_ui( tmp ); /* lo = tmp & 0xffffffff */ 58 | mpz_div_2exp( tmp, tmp, 32 ); /* tmp >>= 32 */ 59 | hi = mpz_get_ui( tmp ); /* hi = tmp & 0xffffffff */ 60 | 61 | mpz_clear( tmp ); 62 | 63 | return (((unsigned long long)hi) << 32) + lo; 64 | } 65 | 66 | char *__idris_strCons(char c, char *s) { 67 | size_t len = strlen(s); 68 | char *result = GC_malloc_atomic(len+2); 69 | result[0] = c; 70 | memcpy(result+1, s, len); 71 | result[len+1] = 0; 72 | return result; 73 | } 74 | 75 | 76 | char *__idris_readStr(FILE* h) { 77 | char *buffer = NULL; 78 | size_t n = 0; 79 | ssize_t len = 0; 80 | 81 | len = getline(&buffer, &n, h); 82 | strtok(buffer, "\n"); 83 | 84 | if (len <= 0) { 85 | return ""; 86 | } else { 87 | return buffer; 88 | } 89 | } 90 | 91 | char* __idris_readChars(int len, FILE* h) { 92 | char* buffer = (char*) GC_malloc(len); 93 | char* read = fgets(buffer, len, h); 94 | if (read == 0) buffer[0] = 0; 95 | return buffer; 96 | } 97 | 98 | 99 | int __idris_writeStr(void* h, char* str) { 100 | FILE* f = (FILE*)h; 101 | if (fputs(str, f) >= 0) { 102 | return 0; 103 | } else { 104 | return -1; 105 | } 106 | } 107 | 108 | static void registerPtr_finalizer(void* obj, void* data) { 109 | void* p = *((void**)obj); 110 | free(p); 111 | } 112 | 113 | void* __idris_registerPtr(void* p, int size) { 114 | void* mp = GC_malloc(sizeof(p)); 115 | memcpy(mp, &p, sizeof(p)); 116 | GC_register_finalizer(mp, registerPtr_finalizer, NULL, NULL, NULL); 117 | return mp; 118 | } 119 | 120 | void* __idris_getRegisteredPtr(void* rp) { 121 | return *((void**)rp); 122 | } 123 | 124 | int __idris_sizeofPtr(void) { 125 | return sizeof((void*)0); 126 | } 127 | 128 | // stdin and friends are often macros, so let C handle that problem. 129 | FILE* __idris_stdin() { 130 | return stdin; 131 | } 132 | 133 | FILE* __idris_stdout() { 134 | return stdout; 135 | } 136 | FILE* __idris_stderr() { 137 | return stderr; 138 | } 139 | 140 | void* fileOpen(char* name, char* mode) { 141 | FILE* f = fopen(name, mode); 142 | return (void*)f; 143 | } 144 | 145 | void fileClose(void* h) { 146 | FILE* f = (FILE*)h; 147 | fclose(f); 148 | } 149 | 150 | int fileEOF(void* h) { 151 | FILE* f = (FILE*)h; 152 | return feof(f); 153 | } 154 | 155 | int fileError(void* h) { 156 | FILE* f = (FILE*)h; 157 | return ferror(f); 158 | } 159 | 160 | void fputStr(void* h, char* str) { 161 | FILE* f = (FILE*)h; 162 | fputs(str, f); 163 | } 164 | 165 | int isNull(void* ptr) { 166 | return ptr==NULL; 167 | } 168 | 169 | char* getEnvPair(int i) { 170 | return *(environ + i); 171 | } 172 | 173 | void idris_memset(void* ptr, size_t offset, uint8_t c, size_t size) { 174 | memset(((uint8_t*)ptr) + offset, c, size); 175 | } 176 | 177 | uint8_t idris_peek(void* ptr, size_t offset) { 178 | return *(((uint8_t*)ptr) + offset); 179 | } 180 | 181 | void idris_poke(void* ptr, size_t offset, uint8_t data) { 182 | *(((uint8_t*)ptr) + offset) = data; 183 | } 184 | 185 | void idris_memmove(void* dest, void* src, size_t dest_offset, size_t src_offset, size_t size) { 186 | memmove(dest + dest_offset, src + src_offset, size); 187 | } 188 | 189 | void *__idris_gmpMalloc(size_t size) { 190 | return GC_malloc(size); 191 | } 192 | 193 | void *__idris_gmpRealloc(void *ptr, size_t oldSize, size_t size) { 194 | return GC_realloc(ptr, size); 195 | } 196 | 197 | void __idris_gmpFree(void *ptr, size_t oldSize) { 198 | GC_free(ptr); 199 | } 200 | 201 | char *__idris_strRev(const char *s) { 202 | int x = strlen(s); 203 | int y = 0; 204 | char *t = GC_malloc(x+1); 205 | 206 | t[x] = '\0'; 207 | while(x>0) { 208 | t[y++] = s[--x]; 209 | } 210 | return t; 211 | } 212 | 213 | int __idris_argc; 214 | char **__idris_argv; 215 | 216 | int idris_numArgs() { 217 | return __idris_argc; 218 | } 219 | 220 | const char* idris_getArg(int i) { 221 | return __idris_argv[i]; 222 | } 223 | 224 | static struct valTy* mkCon(int32_t tag, int nargs) { 225 | int extra = nargs > 1? (nargs - 1)*sizeof(valTy*):0; 226 | valTy* space = alloc(sizeof(valTy)+extra); 227 | space->tag = tag; 228 | return space; 229 | } 230 | 231 | static void addArg(valTy* con, int index, void* arg) { 232 | void* first = con->val; 233 | *(&first+index) = arg; 234 | } 235 | 236 | valTy* idris_mkFileError(void* vm) { 237 | valTy* out = NULL; 238 | switch (errno) { 239 | case ENOENT: 240 | out = mkCon(3,0); 241 | break; 242 | case EAGAIN: 243 | out = mkCon(4,0); 244 | break; 245 | default: 246 | out = mkCon(0,1); 247 | addArg(out, 0, (void*)errno); 248 | } 249 | return out; 250 | } -------------------------------------------------------------------------------- /src/rts/getline.c: -------------------------------------------------------------------------------- 1 | /* $NetBSD: fgetln.c,v 1.9 2008/04/29 06:53:03 martin Exp $ */ 2 | 3 | /*- 4 | * Copyright (c) 2011 The NetBSD Foundation, Inc. 5 | * All rights reserved. 6 | * 7 | * This code is derived from software contributed to The NetBSD Foundation 8 | * by Christos Zoulas. 9 | * 10 | * Redistribution and use in source and binary forms, with or without 11 | * modification, are permitted provided that the following conditions 12 | * are met: 13 | * 1. Redistributions of source code must retain the above copyright 14 | * notice, this list of conditions and the following disclaimer. 15 | * 2. Redistributions in binary form must reproduce the above copyright 16 | * notice, this list of conditions and the following disclaimer in the 17 | * documentation and/or other materials provided with the distribution. 18 | * 19 | * THIS SOFTWARE IS PROVIDED BY THE NETBSD FOUNDATION, INC. AND CONTRIBUTORS 20 | * ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 21 | * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 22 | * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS 23 | * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 24 | * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 25 | * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 26 | * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 27 | * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 28 | * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 29 | * POSSIBILITY OF SUCH DAMAGE. 30 | */ 31 | 32 | #include 33 | #include 34 | #include 35 | #include 36 | #include 37 | 38 | ssize_t 39 | getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp) 40 | { 41 | char *ptr, *eptr; 42 | 43 | 44 | if (*buf == NULL || *bufsiz == 0) { 45 | *bufsiz = BUFSIZ; 46 | if ((*buf = GC_malloc(*bufsiz)) == NULL) 47 | return -1; 48 | } 49 | 50 | for (ptr = *buf, eptr = *buf + *bufsiz;;) { 51 | int c = fgetc(fp); 52 | if (c == -1) { 53 | if (feof(fp)) 54 | return ptr == *buf ? -1 : ptr - *buf; 55 | else 56 | return -1; 57 | } 58 | *ptr++ = c; 59 | if (c == delimiter) { 60 | *ptr = '\0'; 61 | return ptr - *buf; 62 | } 63 | if (ptr + 2 >= eptr) { 64 | char *nbuf; 65 | size_t nbufsiz = *bufsiz * 2; 66 | ssize_t d = ptr - *buf; 67 | if ((nbuf = realloc(*buf, nbufsiz)) == NULL) 68 | return -1; 69 | *buf = nbuf; 70 | *bufsiz = nbufsiz; 71 | eptr = nbuf + nbufsiz; 72 | ptr = nbuf + d; 73 | } 74 | } 75 | } 76 | 77 | ssize_t 78 | getline(char **buf, size_t *bufsiz, FILE *fp) 79 | { 80 | return getdelim(buf, bufsiz, '\n', fp); 81 | } 82 | -------------------------------------------------------------------------------- /src/rts/getline.h: -------------------------------------------------------------------------------- 1 | #ifndef GETLINE_H 2 | #define GETLINE_H 3 | #include 4 | #include 5 | ssize_t getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp); 6 | ssize_t getline(char **buf, size_t *bufsiz, FILE *fp); 7 | #endif // GETLINE_H 8 | -------------------------------------------------------------------------------- /src/rts/idris_buffer.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "idris_buffer.h" 4 | 5 | typedef struct { 6 | int size; 7 | uint8_t data[0]; 8 | } Buffer; 9 | 10 | void* idris_newBuffer(int bytes) { 11 | Buffer* buf = malloc(sizeof(Buffer) + bytes*sizeof(uint8_t)); 12 | if (buf == NULL) { 13 | return NULL; 14 | } 15 | 16 | buf->size = bytes; 17 | memset(buf->data, 0, bytes); 18 | 19 | return buf; 20 | } 21 | 22 | void idris_copyBuffer(void* from, int start, int len, 23 | void* to, int loc) { 24 | Buffer* bfrom = from; 25 | Buffer* bto = to; 26 | 27 | if (loc >= 0 && loc+len <= bto->size) { 28 | memcpy(bto->data + loc, bfrom->data + start, len); 29 | } 30 | } 31 | 32 | int idris_getBufferSize(void* buffer) { 33 | return ((Buffer*)buffer)->size; 34 | } 35 | 36 | void idris_setBufferByte(void* buffer, int loc, uint8_t byte) { 37 | Buffer* b = buffer; 38 | if (loc >= 0 && loc < b->size) { 39 | b->data[loc] = byte; 40 | } 41 | } 42 | 43 | void idris_setBufferString(void* buffer, int loc, char* str) { 44 | Buffer* b = buffer; 45 | int len = strlen(str); 46 | 47 | if (loc >= 0 && loc+len <= b->size) { 48 | memcpy((b->data)+loc, str, len); 49 | } 50 | } 51 | 52 | uint8_t idris_getBufferByte(void* buffer, int loc) { 53 | Buffer* b = buffer; 54 | if (loc >= 0 && loc < b->size) { 55 | return b->data[loc]; 56 | } else { 57 | return 0; 58 | } 59 | } 60 | 61 | int idris_readBuffer(FILE* h, void* buffer, int loc, int max) { 62 | Buffer* b = buffer; 63 | size_t len; 64 | 65 | if (loc >= 0 && loc < b->size) { 66 | if (loc + max > b->size) { 67 | max = b->size - loc; 68 | } 69 | len = fread((b->data)+loc, sizeof(uint8_t), (size_t)max, h); 70 | return len; 71 | } else { 72 | return 0; 73 | } 74 | } 75 | 76 | void idris_writeBuffer(FILE* h, void* buffer, int loc, int len) { 77 | Buffer* b = buffer; 78 | 79 | if (loc >= 0 && loc < b->size) { 80 | if (loc + len > b->size) { 81 | len = b->size - loc; 82 | } 83 | fwrite((b->data)+loc, sizeof(uint8_t), len, h); 84 | } 85 | } 86 | 87 | -------------------------------------------------------------------------------- /src/rts/idris_buffer.h: -------------------------------------------------------------------------------- 1 | #ifndef __BUFFER_H 2 | #define __BUFFER_H 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | void* idris_newBuffer(int bytes); 9 | 10 | int idris_getBufferSize(void* buffer); 11 | 12 | void idris_setBufferByte(void* buffer, int loc, uint8_t byte); 13 | void idris_setBufferString(void* buffer, int loc, char* str); 14 | 15 | void idris_copyBuffer(void* from, int start, int len, 16 | void* to, int loc); 17 | 18 | int idris_readBuffer(FILE* h, void* buffer, int loc, int max); 19 | void idris_writeBuffer(FILE* h, void* buffer, int loc, int len); 20 | 21 | uint8_t idris_getBufferByte(void* buffer, int loc); 22 | 23 | #endif 24 | -------------------------------------------------------------------------------- /src/rts/rts.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | struct valTy { 4 | int32_t tag; 5 | void* val; 6 | }; 7 | 8 | typedef struct valTy valTy; -------------------------------------------------------------------------------- /test/idris001/run: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | 5 | git clone https://github.com/Idris-lang/Idris-dev.git 6 | cd Idris-dev 7 | cabal install -f FFI --enable-tests 8 | cd .. 9 | cabal install 10 | cd Idris-dev 11 | make test_llvm 12 | 13 | 14 | -------------------------------------------------------------------------------- /test/runtest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import Control.Monad 5 | import Data.Char 6 | import Data.List 7 | import Data.Maybe 8 | import qualified Data.Set as S 9 | import Data.Time.Clock 10 | import System.Directory 11 | import System.Environment 12 | import System.FilePath 13 | import System.Exit 14 | import System.Info 15 | import System.IO 16 | import System.Process 17 | 18 | -- Because GHC earlier than 7.8 lacks setEnv 19 | -- Install the setenv package on Windows. 20 | #if __GLASGOW_HASKELL__ < 708 21 | #ifndef mingw32_HOST_OS 22 | import qualified System.Posix.Env as PE(setEnv) 23 | 24 | setEnv k v = PE.setEnv k v True 25 | #else 26 | import System.SetEnv(setEnv) 27 | #endif 28 | #endif 29 | 30 | data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord) 31 | 32 | type Flags = S.Set Flag 33 | 34 | data Status = Success | Failure | Updated deriving (Eq, Show) 35 | 36 | data Config = Config { 37 | flags :: Flags, 38 | idrOpts :: [String], 39 | tests :: [String] 40 | } deriving (Show, Eq) 41 | 42 | isQuiet conf = Quiet `S.member` (flags conf) 43 | showOutput conf = ShowOutput `S.member` (flags conf) 44 | showTime conf = Time `S.member` (flags conf) 45 | showDiff conf = Diff `S.member` (flags conf) 46 | doUpdate conf = Update `S.member` (flags conf) 47 | 48 | checkTestName :: String -> Bool 49 | checkTestName d = (all isDigit $ take 3 $ reverse d) 50 | && (not $ isInfixOf "disabled" d) 51 | 52 | enumTests :: IO [String] 53 | enumTests = do 54 | cwd <- getCurrentDirectory 55 | dirs <- getDirectoryContents cwd 56 | return $ sort $ filter checkTestName dirs 57 | 58 | parseFlag :: String -> Maybe Flag 59 | parseFlag s = case s of 60 | "-u" -> Just Update 61 | "-d" -> Just Diff 62 | "-s" -> Just ShowOutput 63 | "-t" -> Just Time 64 | "-q" -> Just Quiet 65 | _ -> Nothing 66 | 67 | parseFlags :: [String] -> (S.Set Flag, [String]) 68 | parseFlags xs = (S.fromList f, i) 69 | where 70 | f = catMaybes $ map parseFlag fl 71 | (fl, i) = partition (\s -> parseFlag s /= Nothing) xs 72 | 73 | parseArgs :: [String] -> IO Config 74 | parseArgs args = do 75 | (tests, rest) <- case args of 76 | ("all":xs) -> do 77 | et <- enumTests 78 | return (et, xs) 79 | ("without":xs) -> do 80 | t <- enumTests 81 | (blacklist, ys) <- return $ break (== "opts") xs 82 | return (t \\ blacklist, ys \\ ["opts"]) 83 | (x:xs) -> do 84 | exists <- doesDirectoryExist x 85 | return (if checkTestName x && exists then [x] else [], xs) 86 | [] -> do 87 | et <- enumTests 88 | return (et, []) 89 | let (testOpts, idOpts) = parseFlags rest 90 | return $ Config testOpts (idOpts++["--codegen", "llvm"]) tests 91 | 92 | -- "bash" needed because Haskell has cmd as the default shell on windows, and 93 | -- we also want to run the process with another current directory, so we get 94 | -- this thing. 95 | runInShell :: String -> [String] -> IO (ExitCode, String) 96 | runInShell test opts = do 97 | (ec, output, _) <- readCreateProcessWithExitCode 98 | ((proc "bash" ("run":opts)) { cwd = Just test, 99 | std_out = CreatePipe }) 100 | "" 101 | return (ec, output) 102 | 103 | runTest :: Config -> String -> IO Status 104 | runTest conf test = do 105 | -- don't touch the current directory as we want to run these things 106 | -- in parallel in the future 107 | let inTest s = test ++ "/" ++ s 108 | t1 <- getCurrentTime 109 | (exitCode, output) <- runInShell test (idrOpts conf) 110 | t2 <- getCurrentTime 111 | expected <- readFile $ inTest "expected" 112 | writeFile (inTest "output") output 113 | res <- if (norm output == norm expected) 114 | then do putStrLn $ test ++ " finished...success" 115 | return Success 116 | else if doUpdate conf 117 | then do putStrLn $ test ++ " finished...UPDATE" 118 | writeFile (inTest "expected") output 119 | return Updated 120 | else do putStrLn $ test ++ " finished...FAILURE" 121 | _ <- rawSystem "diff" [inTest "output", inTest "expected"] 122 | return Failure 123 | when (showTime conf) $ do 124 | let dt = diffUTCTime t2 t1 125 | putStrLn $ "Duration of " ++ test ++ " was " ++ show dt 126 | return res 127 | where 128 | -- just pretend that backslashes are slashes for comparison 129 | -- purposes to avoid path problems, so don't write any tests 130 | -- that depend on that distinction in other contexts. 131 | -- Also rewrite newlines for consistency. 132 | norm ('\r':'\n':xs) = '\n' : norm xs 133 | norm ('\\':'\\':xs) = '/' : norm xs 134 | norm ('\\':xs) = '/' : norm xs 135 | norm (x : xs) = x : norm xs 136 | norm [] = [] 137 | 138 | printStats :: Config -> [Status] -> IO () 139 | printStats conf stats = do 140 | let total = length stats 141 | let successful = length $ filter (== Success) stats 142 | let failures = length $ filter (== Failure) stats 143 | let updates = length $ filter (== Updated) stats 144 | putStrLn "\n----" 145 | putStrLn $ show total ++ " tests run: " ++ show successful ++ " succesful, " 146 | ++ show failures ++ " failed, " ++ show updates ++ " updated." 147 | let failed = map fst $ filter ((== Failure) . snd) $ zip (tests conf) stats 148 | when (failed /= []) $ do 149 | putStrLn "\nFailed tests:" 150 | mapM_ putStrLn failed 151 | putStrLn "" 152 | 153 | runTests :: Config -> IO Bool 154 | runTests conf = do 155 | stats <- mapM (runTest conf) (tests conf) 156 | unless (isQuiet conf) $ printStats conf stats 157 | return $ all (== Success) stats 158 | 159 | runShow :: Config -> IO Bool 160 | runShow conf = do 161 | mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf) 162 | return True 163 | 164 | runDiff :: Config -> IO Bool 165 | runDiff conf = do 166 | mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":" 167 | ec <- rawSystem "diff" [t++"/output", t++"/expected"] 168 | when (ec == ExitSuccess) $ putStrLn "No differences found.") 169 | (tests conf) 170 | return True 171 | 172 | whisper :: Config -> String -> IO () 173 | whisper conf s = do unless (isQuiet conf) $ putStrLn s 174 | 175 | isWindows :: Bool 176 | isWindows = os `elem` ["win32", "mingw32", "cygwin32"] 177 | 178 | setPath :: Config -> IO () 179 | setPath conf = do 180 | maybeEnv <- lookupEnv "IDRIS" 181 | idrisExists <- case maybeEnv of 182 | Just idrisExe -> do 183 | let exeExtension = if isWindows then ".exe" else "" 184 | doesFileExist (idrisExe ++ exeExtension) 185 | Nothing -> return False 186 | if (idrisExists) 187 | then do 188 | idrisAbs <- makeAbsolute $ fromMaybe "" maybeEnv 189 | setEnv "IDRIS" idrisAbs 190 | whisper conf $ "Using " ++ idrisAbs 191 | else do 192 | path <- getEnv "PATH" 193 | setEnv "IDRIS" "" 194 | let sandbox = "../.cabal-sandbox/bin" 195 | hasBox <- doesDirectoryExist sandbox 196 | bindir <- if hasBox 197 | then do 198 | whisper conf $ "Using Cabal sandbox at " ++ sandbox 199 | makeAbsolute sandbox 200 | else do 201 | stackExe <- findExecutable "stack" 202 | case stackExe of 203 | Just stack -> do 204 | out <- readProcess stack ["path", "--dist-dir"] [] 205 | stackDistDir <- return $ takeWhile (/= '\n') out 206 | let stackDir = "../" ++ stackDistDir ++ "/build/idris" 207 | whisper conf $ "Using stack work dir at " ++ stackDir 208 | makeAbsolute stackDir 209 | Nothing -> return "" 210 | when (bindir /= "") $ setEnv "PATH" (bindir ++ [searchPathSeparator] ++ path) 211 | 212 | main = do 213 | hSetBuffering stdout LineBuffering 214 | withCabal <- doesDirectoryExist "test" 215 | when withCabal $ do 216 | setCurrentDirectory "test" 217 | args <- getArgs 218 | conf <- parseArgs args 219 | -- setPath conf 220 | t1 <- getCurrentTime 221 | res <- case tests conf of 222 | [] -> return True 223 | xs | showOutput conf -> runShow conf 224 | xs | showDiff conf -> runDiff conf 225 | xs -> runTests conf 226 | t2 <- getCurrentTime 227 | when (showTime conf) $ do 228 | let dt = diffUTCTime t2 t1 229 | putStrLn $ "Duration of Entire Test Suite was " ++ show dt 230 | unless res exitFailure 231 | --------------------------------------------------------------------------------