06a43e2 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge branch 'simd' of https://github.com/Ralith/Idris-dev into JavaRepairs

06a43e2Jan Bessai13 years ago

idris.cabal+1−2

compare with master

unifiedsplit

@@ -272,8 +272,7 @@ Executable idris

272 haskeline>=0.7, split, directory,

273 containers, process, transformers, filepath,

274 directory, binary, bytestring, text, pretty,

275− language-java>=0.2.2, libffi, llvm-general>=3.3.0.6 && <3.4,

275+ language-java>=0.2.2, libffi, llvm-general==3.3.3.*

276− vector, vector-binary-instances

277

276

278 Extensions: MultiParamTypeClasses, FunctionalDependencies,

277 Extensions: MultiParamTypeClasses, FunctionalDependencies,

279 FlexibleInstances, TemplateHaskell

278 FlexibleInstances, TemplateHaskell

src/IRTS/CodegenLLVM.hs+157−165

@@ -5,7 +5,6 @@ import IRTS.CodegenCommon

5import IRTS.Lang

6import IRTS.Simplified

7import qualified Core.TT as TT

8−import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)

10import Util.System

9import Util.System

11import Paths_idris

10import Paths_idris

@@ -14,6 +13,9 @@ import LLVM.General.Context

14import LLVM.General.Diagnostic

13import LLVM.General.Diagnostic

15import LLVM.General.AST

14import LLVM.General.AST

16import LLVM.General.AST.AddrSpace

15import LLVM.General.AST.AddrSpace

16+import LLVM.General.Target

17+import LLVM.General.AST.DataLayout

18+import LLVM.General.PassManager

17import qualified LLVM.General.Module as M

19import qualified LLVM.General.Module as M

18import qualified LLVM.General.AST.IntegerPredicate as IPred

20import qualified LLVM.General.AST.IntegerPredicate as IPred

19import qualified LLVM.General.AST.Linkage as L

21import qualified LLVM.General.AST.Linkage as L

@@ -23,17 +25,21 @@ import qualified LLVM.General.AST.Attribute as A

23import qualified LLVM.General.AST.Global as G

25import qualified LLVM.General.AST.Global as G

24import qualified LLVM.General.AST.Constant as C

26import qualified LLVM.General.AST.Constant as C

25import qualified LLVM.General.AST.Float as F

27import qualified LLVM.General.AST.Float as F

28+import qualified LLVM.General.Relocation as R

29+import qualified LLVM.General.CodeModel as CM

30+import qualified LLVM.General.CodeGenOpt as CGO

27import Data.List

32import Data.List

28import Data.Maybe

33import Data.Maybe

29import Data.Word

34import Data.Word

30import Data.Set (Set)

35import Data.Set (Set)

31import qualified Data.Set as S

36import qualified Data.Set as S

32−import qualified Data.Vector.Unboxed as V

37+import qualified Data.Map as M

33import Control.Applicative

38import Control.Applicative

34import Control.Monad.RWS

39import Control.Monad.RWS

35import Control.Monad.Writer

40import Control.Monad.Writer

36import Control.Monad.State

41import Control.Monad.State

42+import Control.Monad.Error

38import qualified System.Info as SI (arch, os)

44import qualified System.Info as SI (arch, os)

39import System.IO

45import System.IO

@@ -43,28 +49,46 @@ import System.Process (rawSystem)

43import System.Exit (ExitCode(..))

49import System.Exit (ExitCode(..))

44import Debug.Trace

50import Debug.Trace

46−data Target = Target { arch :: String, os :: String }

52+data Target = Target { triple :: String, dataLayout :: DataLayout }

48codegenLLVM :: [(TT.Name, SDecl)] ->

54codegenLLVM :: [(TT.Name, SDecl)] ->

55+ String -> -- target triple

56+ String -> -- target CPU

57+ Int -> -- Optimization degree

49 FilePath -> -- output file name

58 FilePath -> -- output file name

50 OutputType ->

59 OutputType ->

51 IO ()

60 IO ()

52−codegenLLVM defs file outty = withContext $ \context -> do

61+codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do

53− let target = Target { arch = SI.arch, os = SI.os }

62+ initializeAllTargets

63+ (target, _) <- failInIO $ lookupTarget Nothing triple

64+ withTargetOptions $ \options ->

65+ withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm ->

66+ do layout <- getTargetMachineDataLayout tm

54− let ast = codegen target (map snd defs)

67+ let ast = codegen (Target triple layout) (map snd defs)

55− result <- M.withModuleFromAST context ast (outputModule file outty)

68+ result <- runErrorT . M.withModuleFromAST context ast $ \m ->

69+ do let opts = defaultCuratedPassSetSpec

70+ { optLevel = Just optimize

71+ , simplifyLibCalls = Just True

72+ , useInlinerWithThreshold = Just 225

73+ }

74+ when (optimize /= 0) $ withPassManager opts $ void . flip runPassManager m

75+ outputModule tm file outty m

56− case result of

76+ case result of

57− Right _ -> return ()

77+ Right _ -> return ()

58− Left msg -> ierror msg

78+ Left msg -> ierror msg

59−

79+

80+failInIO :: ErrorT String IO a -> IO a

81+failInIO = either fail return <=< runErrorT

82+

83+itWidth :: IntTy -> Word32

84+itWidth ITNative = 32

85+itWidth x = fromIntegral $ intTyWidth x

86+

60−outputModule :: FilePath -> OutputType -> M.Module -> IO ()

87+outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()

61−outputModule file Raw m = M.writeBitcodeToFile file m

88+outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m

62−outputModule file Object m = withTmpFile $ \bc -> do

89+outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m

63− outputModule bc Raw m

64− exit <- rawSystem "llc" ["-filetype=obj", "--disable-fp-elim", "-o", file, bc]

65− when (exit /= ExitSuccess) $ ierror "FAILURE: Object generation"

66−outputModule file Executable m = withTmpFile $ \obj -> do

90+outputModule tm file Executable m = withTmpFile $ \obj -> do

67− outputModule obj Object m

91+ outputModule tm obj Object m

68 cc <- getCC

92 cc <- getCC

69 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir

93 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir

70 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]

94 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]

@@ -125,10 +149,10 @@ initDefs tgt =

125 }

149 }

126 , rtsFun "intStr" ptrI8 [IntegerType 64]

150 , rtsFun "intStr" ptrI8 [IntegerType 64]

127 [ BasicBlock (UnName 0)

151 [ BasicBlock (UnName 0)

128− [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)]

152+ [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]

129 , UnName 2 := simpleCall "snprintf"

153 , UnName 2 := simpleCall "snprintf"

130 [ LocalReference (UnName 1)

154 [ LocalReference (UnName 1)

131− , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)

155+ , ConstantOperand (C.Int (tgtWordSize tgt) 21)

132 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]

156 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]

133 , LocalReference (UnName 0)

157 , LocalReference (UnName 0)

134 ]

158 ]

@@ -136,10 +160,12 @@ initDefs tgt =

136 (Do $ Ret (Just (LocalReference (UnName 1))) [])

160 (Do $ Ret (Just (LocalReference (UnName 1))) [])

137 ]

161 ]

138 , exfun "llvm.trap" VoidType [] False

162 , exfun "llvm.trap" VoidType [] False

163+ -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False

164+ -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False

165+ , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False

139 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True

166 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True

140 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False

167 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False

141 , exfun "strlen" intPtr [ptrI8] False

168 , exfun "strlen" intPtr [ptrI8] False

142− , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False

143 , exfun "GC_init" VoidType [] False

169 , exfun "GC_init" VoidType [] False

144 , exfun "GC_malloc" ptrI8 [intPtr] False

170 , exfun "GC_malloc" ptrI8 [intPtr] False

145 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False

171 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False

@@ -167,7 +193,7 @@ initDefs tgt =

167 , GlobalDefinition mainDef

193 , GlobalDefinition mainDef

168 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]

194 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]

169 where

195 where

170− intPtr = IntegerType (fromInteger $ tgtWordSize tgt)

196+ intPtr = IntegerType (tgtWordSize tgt)

171 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)

197 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)

172 pmpz = PointerType mpzTy (AddrSpace 0)

198 pmpz = PointerType mpzTy (AddrSpace 0)

173

199

@@ -193,18 +219,24 @@ initDefs tgt =

193 exVar :: String -> Type -> Definition

219 exVar :: String -> Type -> Definition

194 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }

220 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }

195

221

196− stdinName :: Target -> String

222+isApple :: Target -> Bool

197− stdinName (Target { os = "darwin" }) = "__stdinp"

223+isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t

224+

225+stdinName, stdoutName, stderrName :: Target -> String

226+stdinName t | isApple t = "__stdinp"

198− stdinName _ = "stdin"

227+stdinName _ = "stdin"

199− stdoutName :: Target -> String

228+stdoutName t | isApple t = "__stdoutp"

200− stdoutName (Target { os = "darwin" }) = "__stdoutp"

201− stdoutName _ = "stdout"

229+stdoutName _ = "stdout"

202− stderrName :: Target -> String

230+stderrName t | isApple t = "__stderrp"

203− stderrName (Target { os = "darwin" }) = "__stderrp"

204− stderrName _ = "stderr"

231+stderrName _ = "stderr"

232+

233+getStdIn, getStdOut, getStdErr :: Codegen Operand

234+getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target

235+getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target

236+getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target

205

237

206codegen :: Target -> [SDecl] -> Module

238codegen :: Target -> [SDecl] -> Module

207−codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)

239+codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs)

208 where

240 where

209 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0

241 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0

210

242

@@ -363,13 +395,13 @@ alloc ty = do

363sizeOf :: Type -> Codegen Operand

395sizeOf :: Type -> Codegen Operand

364sizeOf ty = ConstantOperand . C.PtrToInt

396sizeOf ty = ConstantOperand . C.PtrToInt

365 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])

397 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])

366− . IntegerType . fromIntegral <$> getWordSize

398+ . IntegerType <$> getWordSize

367

399

368−tgtWordSize :: Target -> Integer

400+tgtWordSize :: Target -> Word32

369−tgtWordSize (Target { arch = "i386" }) = 32

401+tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =

370−tgtWordSize (Target { arch = "x86_64" }) = 64

402+ fst . fromJust $ M.lookup (AddrSpace 0) l

371

403

372−getWordSize :: Codegen Integer

404+getWordSize :: Codegen Word32

373getWordSize = tgtWordSize <$> asks target

405getWordSize = tgtWordSize <$> asks target

374

406

375cgExpr :: SExp -> Codegen (Maybe Operand)

407cgExpr :: SExp -> Codegen (Maybe Operand)

@@ -554,7 +586,7 @@ cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)

554cgChainCase caseValPtr defExp alts = do

586cgChainCase caseValPtr defExp alts = do

555 let (caseTy, comparator) =

587 let (caseTy, comparator) =

556 case head alts of

588 case head alts of

557− SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp")

589+ SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")

558 SConstCase (TT.Str _) _ -> (FString, "strcmp")

590 SConstCase (TT.Str _) _ -> (FString, "strcmp")

559 caseVal <- unbox caseTy caseValPtr

591 caseVal <- unbox caseTy caseValPtr

560 defBlockName <- getName "default"

592 defBlockName <- getName "default"

@@ -680,11 +712,6 @@ cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)

680cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)

712cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)

681cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)

713cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)

682cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)

714cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)

683−cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v)

684−cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v)

685−cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v)

686−cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v)

687−

688cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])

715cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])

689cgConst' (TT.Fl f) = C.Float (F.Double f)

716cgConst' (TT.Fl f) = C.Float (F.Double f)

690cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c

717cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c

@@ -692,16 +719,12 @@ cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fro

692cgConst' x = ierror $ "Unsupported constant: " ++ show x

719cgConst' x = ierror $ "Unsupported constant: " ++ show x

693

720

694cgConst :: TT.Const -> Codegen Operand

721cgConst :: TT.Const -> Codegen Operand

695−cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)

722+cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)

696−cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)

723+cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)

697−cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)

724+cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)

698−cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)

725+cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)

699−cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)

700−cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c)

701−cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c)

702−cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c)

703−cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c)

726+cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)

704−cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)

727+cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)

705cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)

728cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)

706cgConst c@(TT.Str s) = do

729cgConst c@(TT.Str s) = do

707 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)

730 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)

@@ -713,7 +736,7 @@ cgConst c@(TT.BI i) = do

713 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]

736 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]

714 , ConstantOperand $ C.Int 32 10

737 , ConstantOperand $ C.Int 32 10

715 ]

738 ]

716− box (FArith (ATInt ITBig)) mpz

739+ box (FInt ITBig) mpz

717cgConst x = return $ ConstantOperand nullValue

740cgConst x = return $ ConstantOperand nullValue

718

741

719numDigits :: Integer -> Integer -> Integer

742numDigits :: Integer -> Integer -> Integer

@@ -759,82 +782,72 @@ ffunDecl name rty argtys =

759 }

782 }

760

783

761ftyToTy :: FType -> Type

784ftyToTy :: FType -> Type

762−ftyToTy (FArith (ATInt ITNative)) = IntegerType 32

785+ftyToTy (FInt ITNative) = IntegerType 32

763−ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)

786+ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)

764−ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)

787+ftyToTy (FInt ty) = IntegerType (itWidth ty)

765−ftyToTy (FArith (ATInt (ITVec e c)))

766− = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e))

767ftyToTy FChar = IntegerType 32

788ftyToTy FChar = IntegerType 32

768ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)

789ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)

769ftyToTy FUnit = VoidType

790ftyToTy FUnit = VoidType

770ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)

791ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)

771−ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE

792+ftyToTy FDouble = FloatingPointType 64 IEEE

772ftyToTy FAny = valueType

793ftyToTy FAny = valueType

773

794

774−-- Only use when known not to be ITBig

775−itWidth :: IntTy -> Word32

776−itWidth ITNative = 32

777−itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x

778−

779cgOp :: PrimFn -> [Operand] -> Codegen Operand

795cgOp :: PrimFn -> [Operand] -> Codegen Operand

780cgOp (LTrunc ITBig ity) [x] = do

796cgOp (LTrunc ITBig ity) [x] = do

781− nx <- unbox (FArith (ATInt ITBig)) x

797+ nx <- unbox (FInt ITBig) x

782 val <- inst $ simpleCall "mpz_get_ull" [nx]

798 val <- inst $ simpleCall "mpz_get_ull" [nx]

783 v <- case ity of

799 v <- case ity of

784− (ITFixed IT64) -> return val

800+ IT64 -> return val

785− _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []

801+ _ -> inst $ Trunc val (IntegerType $ itWidth ity) []

786− box (FArith (ATInt ity)) v

802+ box (FInt ity) v

787cgOp (LZExt from ITBig) [x] = do

803cgOp (LZExt from ITBig) [x] = do

788− nx <- unbox (FArith (ATInt from)) x

804+ nx <- unbox (FInt from) x

789 nx' <- case from of

805 nx' <- case from of

790− (ITFixed IT64) -> return nx

806+ IT64 -> return nx

791 _ -> inst $ ZExt nx (IntegerType 64) []

807 _ -> inst $ ZExt nx (IntegerType 64) []

792 mpz <- alloc mpzTy

808 mpz <- alloc mpzTy

793 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']

809 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']

794− box (FArith (ATInt ITBig)) mpz

810+ box (FInt ITBig) mpz

795cgOp (LSExt from ITBig) [x] = do

811cgOp (LSExt from ITBig) [x] = do

796− nx <- unbox (FArith (ATInt from)) x

812+ nx <- unbox (FInt from) x

797 nx' <- case from of

813 nx' <- case from of

798− (ITFixed IT64) -> return nx

814+ IT64 -> return nx

799 _ -> inst $ SExt nx (IntegerType 64) []

815 _ -> inst $ SExt nx (IntegerType 64) []

800 mpz <- alloc mpzTy

816 mpz <- alloc mpzTy

801 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']

817 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']

802− box (FArith (ATInt ITBig)) mpz

818+ box (FInt ITBig) mpz

803−

819+

804−cgOp (LLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y

820+cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y

805−cgOp (LLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y

821+cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y

806−cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y

822+cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y

807−cgOp (LGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y

823+cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y

808−cgOp (LGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y

824+cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y

809−cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y

825+cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y

810−cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y

826+cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y

811−cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y

827+cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y

812−cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y

828+cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y

813−cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y

829+cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y

814cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y

830cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y

815cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y

831cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y

816cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y

832cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y

817cgOp (LCompl ITBig) [x] = mpzUn "com" x

833cgOp (LCompl ITBig) [x] = mpzUn "com" x

818

834

819−cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]

820− | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x

835+cgOp (LTrunc from to) [x] | itWidth from > itWidth to = iCoerce Trunc from to x

821−cgOp (LZExt (ITFixed from) (ITFixed to)) [x]

822− | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x

836+cgOp (LZExt from to) [x] | itWidth from < itWidth to = iCoerce ZExt from to x

823−cgOp (LSExt (ITFixed from) (ITFixed to)) [x]

824− | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x

837+cgOp (LSExt from to) [x] | itWidth from < itWidth to = iCoerce SExt from to x

825−

838+

826−cgOp (LLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y

839+cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y

827−cgOp (LLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y

840+cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y

828−cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y

841+cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y

829−cgOp (LGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y

842+cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y

830−cgOp (LGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y

843+cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y

831−cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False)

844+cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)

832−cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False)

845+cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)

833−cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False)

846+cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)

834−cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False)

835−cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem

836cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)

847cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)

837cgOp (LURem ity) [x,y] = ibin ity x y URem

848cgOp (LURem ity) [x,y] = ibin ity x y URem

849+cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv False)

850+cgOp (LSRem ity) [x,y] = ibin ity x y SRem

838cgOp (LAnd ity) [x,y] = ibin ity x y And

851cgOp (LAnd ity) [x,y] = ibin ity x y And

839cgOp (LOr ity) [x,y] = ibin ity x y Or

852cgOp (LOr ity) [x,y] = ibin ity x y Or

840cgOp (LXOr ity) [x,y] = ibin ity x y Xor

853cgOp (LXOr ity) [x,y] = ibin ity x y Xor

@@ -843,26 +856,7 @@ cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False)

843cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)

856cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)

844cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)

857cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)

845

858

846−cgOp (LMkVec ety c) xs | c == length xs = do

859+cgOp LNoOp xs = return $ last xs

847− nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs

848− vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) [])

849− (ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety))))

850− (zip nxs [0..])

851− box (FArith (ATInt (ITVec ety c))) vec

852−

853−cgOp (LIdxVec ety c) [v,i] = do

854− nv <- unbox (FArith (ATInt (ITVec ety c))) v

855− ni <- unbox (FArith (ATInt (ITFixed IT32))) i

856− elt <- inst $ ExtractElement nv ni []

857− box (FArith (ATInt (ITFixed ety))) elt

858−

859−cgOp (LUpdateVec ety c) [v,i,e] = do

860− let fty = FArith (ATInt (ITVec ety c))

861− nv <- unbox fty v

862− ni <- unbox (FArith (ATInt (ITFixed IT32))) i

863− ne <- unbox (FArith (ATInt (ITFixed ety))) e

864− nv' <- inst $ InsertElement nv ne ni []

865− box fty nv'

866

860

867cgOp LStrEq [x,y] = do

861cgOp LStrEq [x,y] = do

868 x' <- unbox FString x

862 x' <- unbox FString x

@@ -870,7 +864,7 @@ cgOp LStrEq [x,y] = do

870 cmp <- inst $ simpleCall "strcmp" [x', y']

864 cmp <- inst $ simpleCall "strcmp" [x', y']

871 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []

865 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []

872 val <- inst $ ZExt flag (IntegerType 32) []

866 val <- inst $ ZExt flag (IntegerType 32) []

873− box (FArith (ATInt (ITFixed IT32))) val

867+ box (FInt IT32) val

874

868

875cgOp LStrLt [x,y] = do

869cgOp LStrLt [x,y] = do

876 nx <- unbox FString x

870 nx <- unbox FString x

@@ -878,10 +872,10 @@ cgOp LStrLt [x,y] = do

878 cmp <- inst $ simpleCall "strcmp" [nx, ny]

872 cmp <- inst $ simpleCall "strcmp" [nx, ny]

879 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []

873 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []

880 val <- inst $ ZExt flag (IntegerType 32) []

874 val <- inst $ ZExt flag (IntegerType 32) []

881− box (FArith (ATInt (ITFixed IT32))) val

875+ box (FInt IT32) val

882

876

883cgOp (LIntStr ITBig) [x] = do

877cgOp (LIntStr ITBig) [x] = do

884− x' <- unbox (FArith (ATInt ITBig)) x

878+ x' <- unbox (FInt ITBig) x

885 ustr <- inst $ simpleCall "__gmpz_get_str"

879 ustr <- inst $ simpleCall "__gmpz_get_str"

886 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))

880 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))

887 , ConstantOperand (C.Int 32 10)

881 , ConstantOperand (C.Int 32 10)

@@ -889,7 +883,7 @@ cgOp (LIntStr ITBig) [x] = do

889 ]

883 ]

890 box FString ustr

884 box FString ustr

891cgOp (LIntStr ity) [x] = do

885cgOp (LIntStr ity) [x] = do

892− x' <- unbox (FArith (ATInt ity)) x

886+ x' <- unbox (FInt ity) x

893 x'' <- if itWidth ity < 64

887 x'' <- if itWidth ity < 64

894 then inst $ SExt x' (IntegerType 64) []

888 then inst $ SExt x' (IntegerType 64) []

895 else return x'

889 else return x'

@@ -898,7 +892,7 @@ cgOp (LStrInt ITBig) [s] = do

898 ns <- unbox FString s

892 ns <- unbox FString s

899 mpz <- alloc mpzTy

893 mpz <- alloc mpzTy

900 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]

894 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]

901− box (FArith (ATInt ITBig)) mpz

895+ box (FInt ITBig) mpz

902cgOp (LStrInt ity) [s] = do

896cgOp (LStrInt ity) [s] = do

903 ns <- unbox FString s

897 ns <- unbox FString s

904 nx <- inst $ simpleCall "strtoll"

898 nx <- inst $ simpleCall "strtoll"

@@ -907,9 +901,9 @@ cgOp (LStrInt ity) [s] = do

907 , ConstantOperand $ C.Int 32 10

901 , ConstantOperand $ C.Int 32 10

908 ]

902 ]

909 nx' <- case ity of

903 nx' <- case ity of

910− (ITFixed IT64) -> return nx

904+ IT64 -> return nx

911 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []

905 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []

912− box (FArith (ATInt ity)) nx'

906+ box (FInt ity) nx'

913

907

914cgOp LStrConcat [x,y] = cgStrCat x y

908cgOp LStrConcat [x,y] = cgStrCat x y

915

909

@@ -928,7 +922,7 @@ cgOp LStrHead [c] = do

928

922

929cgOp LStrIndex [s, i] = do

923cgOp LStrIndex [s, i] = do

930 ns <- unbox FString s

924 ns <- unbox FString s

931− ni <- unbox (FArith (ATInt (ITFixed IT32))) i

925+ ni <- unbox (FInt IT32) i

932 p <- inst $ GetElementPtr True ns [ni] []

926 p <- inst $ GetElementPtr True ns [ni] []

933 c <- inst $ Load False p Nothing 0 []

927 c <- inst $ Load False p Nothing 0 []

934 c' <- inst $ ZExt c (IntegerType 32) []

928 c' <- inst $ ZExt c (IntegerType 32) []

@@ -945,9 +939,9 @@ cgOp LStrLen [s] = do

945 ws <- getWordSize

939 ws <- getWordSize

946 len' <- case ws of

940 len' <- case ws of

947 32 -> return len

941 32 -> return len

948− x | x > 32 -> inst $ Trunc len (IntegerType $ fromInteger x) []

942+ x | x > 32 -> inst $ Trunc len (IntegerType 32) []

949− | x < 32 -> inst $ ZExt len (IntegerType $ fromInteger x) []

943+ | x < 32 -> inst $ ZExt len (IntegerType 32) []

950− box (FArith (ATInt (ITFixed IT32))) len'

944+ box (FInt IT32) len'

951

945

952cgOp LReadStr [p] = do

946cgOp LReadStr [p] = do

953 np <- unbox FPtr p

947 np <- unbox FPtr p

@@ -955,24 +949,26 @@ cgOp LReadStr [p] = do

955 box FString s

949 box FString s

956

950

957cgOp LStdIn [] = do

951cgOp LStdIn [] = do

952+ stdin <- getStdIn

958− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdin") Nothing 0 []

953+ ptr <- inst $ Load False stdin Nothing 0 []

959 box FPtr ptr

954 box FPtr ptr

960cgOp LStdOut [] = do

955cgOp LStdOut [] = do

956+ stdout <- getStdOut

961− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdout") Nothing 0 []

957+ ptr <- inst $ Load False stdout Nothing 0 []

962 box FPtr ptr

958 box FPtr ptr

963cgOp LStdErr [] = do

959cgOp LStdErr [] = do

960+ stdErr <- getStdErr

964− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stderr") Nothing 0 []

961+ ptr <- inst $ Load False stdErr Nothing 0 []

965 box FPtr ptr

962 box FPtr ptr

966

963

967−

968cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("

964cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("

969 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"

965 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"

970

966

971−iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand

967+iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> IntTy -> IntTy -> Operand -> Codegen Operand

972iCoerce operator from to x = do

968iCoerce operator from to x = do

973− x' <- unbox (FArith (ATInt (ITFixed from))) x

969+ x' <- unbox (FInt from) x

974− x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed from)))) []

970+ x'' <- inst $ operator x' (IntegerType $ itWidth to) []

975− box (FArith (ATInt (ITFixed to))) x''

971+ box (FInt to) x''

976

972

977cgStrCat :: Operand -> Operand -> Codegen Operand

973cgStrCat :: Operand -> Operand -> Codegen Operand

978cgStrCat x y = do

974cgStrCat x y = do

@@ -981,7 +977,7 @@ cgStrCat x y = do

981 xlen <- inst $ simpleCall "strlen" [x']

977 xlen <- inst $ simpleCall "strlen" [x']

982 ylen <- inst $ simpleCall "strlen" [y']

978 ylen <- inst $ simpleCall "strlen" [y']

983 zlen <- inst $ Add False True xlen ylen []

979 zlen <- inst $ Add False True xlen ylen []

984− ws <- fromIntegral <$> getWordSize

980+ ws <- getWordSize

985 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []

981 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []

986 mem <- allocAtomic total

982 mem <- allocAtomic total

987 inst $ simpleCall "memcpy" [mem, x', xlen]

983 inst $ simpleCall "memcpy" [mem, x', xlen]

@@ -998,54 +994,50 @@ cgStrCat x y = do

998ibin :: IntTy -> Operand -> Operand

994ibin :: IntTy -> Operand -> Operand

999 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

995 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

1000ibin ity x y instCon = do

996ibin ity x y instCon = do

1001− nx <- unbox (FArith (ATInt ity)) x

997+ nx <- unbox (FInt ity) x

1002− ny <- unbox (FArith (ATInt ity)) y

998+ ny <- unbox (FInt ity) y

1003 nr <- inst $ instCon nx ny []

999 nr <- inst $ instCon nx ny []

1004− box (FArith (ATInt ity)) nr

1000+ box (FInt ity) nr

1005

1001

1006iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

1002iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

1007iun ity x instCon = do

1003iun ity x instCon = do

1008− nx <- unbox (FArith (ATInt ity)) x

1004+ nx <- unbox (FInt ity) x

1009 nr <- inst $ instCon nx []

1005 nr <- inst $ instCon nx []

1010− box (FArith (ATInt ity)) nr

1006+ box (FInt ity) nr

1011

1007

1012iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1008iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1013iCmp ity pred x y = do

1009iCmp ity pred x y = do

1014− nx <- unbox (FArith (ATInt ity)) x

1010+ nx <- unbox (FInt ity) x

1015− ny <- unbox (FArith (ATInt ity)) y

1011+ ny <- unbox (FInt ity) y

1016 nr <- inst $ ICmp pred nx ny []

1012 nr <- inst $ ICmp pred nx ny []

1017− nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) []

1013+ nr' <- inst $ ZExt nr (IntegerType 32) []

1018− box (cmpResultTy ity) nr'

1014+ box (FInt IT32) nr'

1019−

1020−cmpResultTy :: IntTy -> FType

1021−cmpResultTy v@(ITVec _ _) = FArith (ATInt v)

1022−cmpResultTy _ = FArith (ATInt (ITFixed IT32))

1023

1015

1024mpzBin :: String -> Operand -> Operand -> Codegen Operand

1016mpzBin :: String -> Operand -> Operand -> Codegen Operand

1025mpzBin name x y = do

1017mpzBin name x y = do

1026− nx <- unbox (FArith (ATInt ITBig)) x

1018+ nx <- unbox (FInt ITBig) x

1027− ny <- unbox (FArith (ATInt ITBig)) y

1019+ ny <- unbox (FInt ITBig) y

1028 nz <- alloc mpzTy

1020 nz <- alloc mpzTy

1029 inst' $ simpleCall "__gmpz_init" [nz]

1021 inst' $ simpleCall "__gmpz_init" [nz]

1030 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]

1022 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]

1031− box (FArith (ATInt ITBig)) nz

1023+ box (FInt ITBig) nz

1032

1024

1033mpzUn :: String -> Operand -> Codegen Operand

1025mpzUn :: String -> Operand -> Codegen Operand

1034mpzUn name x = do

1026mpzUn name x = do

1035− nx <- unbox (FArith (ATInt ITBig)) x

1027+ nx <- unbox (FInt ITBig) x

1036 nz <- alloc mpzTy

1028 nz <- alloc mpzTy

1037 inst' $ simpleCall "__gmpz_init" [nz]

1029 inst' $ simpleCall "__gmpz_init" [nz]

1038 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]

1030 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]

1039− box (FArith (ATInt ITBig)) nz

1031+ box (FInt ITBig) nz

1040

1032

1041mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1033mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand

1042mpzCmp pred x y = do

1034mpzCmp pred x y = do

1043− nx <- unbox (FArith (ATInt ITBig)) x

1035+ nx <- unbox (FInt ITBig) x

1044− ny <- unbox (FArith (ATInt ITBig)) y

1036+ ny <- unbox (FInt ITBig) y

1045 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]

1037 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]

1046 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []

1038 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []

1047 i <- inst $ ZExt result (IntegerType 32) []

1039 i <- inst $ ZExt result (IntegerType 32) []

1048− box (FArith (ATInt (ITFixed IT32))) i

1040+ box (FInt IT32) i

1049

1041

1050simpleCall :: String -> [Operand] -> Instruction

1042simpleCall :: String -> [Operand] -> Instruction

1051simpleCall name args =

1043simpleCall name args =

src/IRTS/Compiler.hs+10−7

@@ -30,8 +30,8 @@ import System.FilePath ((</>), addTrailingPathSeparator)

31import Paths_idris

33−compile :: Target -> FilePath -> Term -> Idris ()

33+compile :: Codegen -> FilePath -> Term -> Idris ()

34−compile target f tm

34+compile codegen f tm

35 = do checkMVs

36 let tmnames = namesUsed (STerm tm)

37 usedIn <- mapM (allNames []) tmnames

@@ -39,9 +39,9 @@ compile target f tm

39 defsIn <- mkDecls tm (concat used)

40 findUnusedArgs (concat used)

41 maindef <- irMain tm

42− objs <- getObjectFiles target

42+ objs <- getObjectFiles codegen

43− libs <- getLibs target

43+ libs <- getLibs codegen

44− hdrs <- getHdrs target

44+ hdrs <- getHdrs codegen

45 let defs = defsIn ++ [(MN 0 "runMain", maindef)]

46 -- iputStrLn $ showSep "\n" (map show defs)

47 let (nexttag, tagged) = addTags 65536 (liftAll defs)

@@ -64,9 +64,12 @@ compile target f tm

64 case dumpDefun of

65 Nothing -> return ()

66 Just f -> liftIO $ writeFile f (dumpDefuns defuns)

67+ triple <- targetTriple

68+ cpu <- targetCPU

69+ optimize <- optLevel

67 iLOG "Building output"

70 iLOG "Building output"

68 case checked of

71 case checked of

69− OK c -> liftIO $ case target of

72+ OK c -> liftIO $ case codegen of

70 ViaC ->

73 ViaC ->

71 codegenC c f outty hdrs

74 codegenC c f outty hdrs

72 (concatMap mkObj objs)

75 (concatMap mkObj objs)

@@ -77,7 +80,7 @@ compile target f tm

77 codegenJavaScript JavaScript c f outty

80 codegenJavaScript JavaScript c f outty

78 ViaNode ->

81 ViaNode ->

79 codegenJavaScript Node c f outty

82 codegenJavaScript Node c f outty

80− ViaLLVM -> codegenLLVM c f outty

83+ ViaLLVM -> codegenLLVM c triple cpu optimize f outty

82 Bytecode -> dumpBC c f

85 Bytecode -> dumpBC c f

83 Error e -> fail $ show e

86 Error e -> fail $ show e

src/IRTS/LParser.hs+3−3

@@ -49,8 +49,8 @@ strlit = PTok.stringLiteral lexer

49chlit = PTok.charLiteral lexer

50lchar = lexeme.char

52−fovm :: Target -> OutputType -> FilePath -> IO ()

52+fovm :: Codegen -> OutputType -> FilePath -> IO ()

53−fovm tgt outty f

53+fovm cgn outty f

54 = do defs <- parseFOVM f

55 let (nexttag, tagged) = addTags 0 (liftAll defs)

56 ctxtIn = addAlist tagged emptyContext

@@ -59,7 +59,7 @@ fovm tgt outty f

59 let checked = checkDefs defuns (toAlist defuns)

60-- print checked

61 case checked of

62− OK c -> case tgt of

62+ OK c -> case cgn of

63 ViaC -> codegenC c "a.out" outty ["math.h"] "" "" TRACE

64 ViaJava -> codegenJava [] c "a.out" [] [] outty

65 Error e -> fail $ show e

src/Idris/AbsSyntax.hs+49−19

@@ -30,19 +30,19 @@ import Util.System

30getContext :: Idris Context

31getContext = do i <- getIState; return (tt_ctxt i)

33−forTarget :: Target -> [(Target, a)] -> [a]

33+forCodegen :: Codegen -> [(Codegen, a)] -> [a]

34−forTarget tgt xs = [x | (tgt', x) <- xs, tgt == tgt']

34+forCodegen tgt xs = [x | (tgt', x) <- xs, tgt == tgt']

36−getObjectFiles :: Target -> Idris [FilePath]

36+getObjectFiles :: Codegen -> Idris [FilePath]

37−getObjectFiles tgt = do i <- getIState; return (forTarget tgt $ idris_objs i)

37+getObjectFiles tgt = do i <- getIState; return (forCodegen tgt $ idris_objs i)

39−addObjectFile :: Target -> FilePath -> Idris ()

39+addObjectFile :: Codegen -> FilePath -> Idris ()

40addObjectFile tgt f = do i <- getIState; putIState $ i { idris_objs = (tgt, f) : idris_objs i }

42−getLibs :: Target -> Idris [String]

42+getLibs :: Codegen -> Idris [String]

43−getLibs tgt = do i <- getIState; return (forTarget tgt $ idris_libs i)

43+getLibs tgt = do i <- getIState; return (forCodegen tgt $ idris_libs i)

45−addLib :: Target -> String -> Idris ()

45+addLib :: Codegen -> String -> Idris ()

46addLib tgt f = do i <- getIState; putIState $ i { idris_libs = (tgt, f) : idris_libs i }

48addDyLib :: [String] -> Idris (Either DynamicLib String)

@@ -55,7 +55,7 @@ addDyLib libs = do i <- getIState

55 putIState $ i { idris_dynamic_libs = x:ls }

56 return (Left x)

58−addHdr :: Target -> String -> Idris ()

58+addHdr :: Codegen -> String -> Idris ()

59addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = (tgt, f) : idris_hdrs i }

61addLangExt :: LanguageExt -> Idris ()

@@ -163,8 +163,8 @@ addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

163clearIBC :: Idris ()

164clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }

165

166−getHdrs :: Target -> Idris [String]

166+getHdrs :: Codegen -> Idris [String]

167−getHdrs tgt = do i <- getIState; return (forTarget tgt $ idris_hdrs i)

167+getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

168

169setErrLine :: Int -> Idris ()

170setErrLine x = do i <- getIState;

@@ -345,15 +345,15 @@ getQuiet = do i <- getIState

345 let opts = idris_options i

346 return (opt_quiet opts)

347

348−setTarget :: Target -> Idris ()

348+setCodegen :: Codegen -> Idris ()

349−setTarget t = do i <- getIState

349+setCodegen t = do i <- getIState

350− let opts = idris_options i

350+ let opts = idris_options i

351− let opt' = opts { opt_target = t }

351+ let opt' = opts { opt_codegen = t }

352− putIState $ i { idris_options = opt' }

352+ putIState $ i { idris_options = opt' }

353

354−target :: Idris Target

354+codegen :: Idris Codegen

355−target = do i <- getIState

355+codegen = do i <- getIState

356− return (opt_target (idris_options i))

356+ return (opt_codegen (idris_options i))

357

358setOutputTy :: OutputType -> Idris ()

359setOutputTy t = do i <- getIState

@@ -370,6 +370,36 @@ setIdeSlave True = do i <- getIState

370 putIState $ i { idris_outputmode = (IdeSlave 0) }

371setIdeSlave False = return ()

372

373+setTargetTriple :: String -> Idris ()

374+setTargetTriple t = do i <- getIState

375+ let opts = idris_options i

376+ opt' = opts { opt_triple = t }

377+ putIState $ i { idris_options = opt' }

378+

379+targetTriple :: Idris String

380+targetTriple = do i <- getIState

381+ return (opt_triple (idris_options i))

382+

383+setTargetCPU :: String -> Idris ()

384+setTargetCPU t = do i <- getIState

385+ let opts = idris_options i

386+ opt' = opts { opt_cpu = t }

387+ putIState $ i { idris_options = opt' }

388+

389+targetCPU :: Idris String

390+targetCPU = do i <- getIState

391+ return (opt_cpu (idris_options i))

392+

393+setOptLevel :: Int -> Idris ()

394+setOptLevel t = do i <- getIState

395+ let opts = idris_options i

396+ opt' = opts { opt_optLevel = t }

397+ putIState $ i { idris_options = opt' }

398+

399+optLevel :: Idris Int

400+optLevel = do i <- getIState

401+ return (opt_optLevel (idris_options i))

402+

373verbose :: Idris Bool

403verbose :: Idris Bool

374verbose = do i <- getIState

404verbose = do i <- getIState

375 return (opt_verbose (idris_options i))

405 return (opt_verbose (idris_options i))

src/Idris/AbsSyntaxTree.hs+25−16

@@ -33,10 +33,13 @@ data IOption = IOption { opt_logLevel :: Int,

33 opt_repl :: Bool,

34 opt_verbose :: Bool,

35 opt_quiet :: Bool,

36− opt_target :: Target,

36+ opt_codegen :: Codegen,

37 opt_outputTy :: OutputType,

38 opt_ibcsubdir :: FilePath,

39 opt_importdirs :: [FilePath],

40+ opt_triple :: String,

41+ opt_cpu :: String,

42+ opt_optLevel :: Int,

40 opt_cmdline :: [Opt] -- remember whole command line

43 opt_cmdline :: [Opt] -- remember whole command line

41 }

44 }

42 deriving (Show, Eq)

45 deriving (Show, Eq)

@@ -50,10 +53,13 @@ defaultOpts = IOption { opt_logLevel = 0

50 , opt_repl = True

53 , opt_repl = True

51 , opt_verbose = True

54 , opt_verbose = True

52 , opt_quiet = False

55 , opt_quiet = False

53− , opt_target = ViaC

56+ , opt_codegen = ViaC

54 , opt_outputTy = Executable

57 , opt_outputTy = Executable

55 , opt_ibcsubdir = ""

58 , opt_ibcsubdir = ""

56 , opt_importdirs = []

59 , opt_importdirs = []

60+ , opt_triple = ""

61+ , opt_cpu = ""

62+ , opt_optLevel = 2

57 , opt_cmdline = []

63 , opt_cmdline = []

58 }

64 }

@@ -95,9 +101,9 @@ data IState = IState {

95 syntax_keywords :: [String],

101 syntax_keywords :: [String],

96 imported :: [FilePath], -- ^ The imported modules

102 imported :: [FilePath], -- ^ The imported modules

97 idris_scprims :: [(Name, (Int, PrimFn))],

103 idris_scprims :: [(Name, (Int, PrimFn))],

98− idris_objs :: [(Target, FilePath)],

104+ idris_objs :: [(Codegen, FilePath)],

99− idris_libs :: [(Target, String)],

105+ idris_libs :: [(Codegen, String)],

100− idris_hdrs :: [(Target, String)],

106+ idris_hdrs :: [(Codegen, String)],

101 proof_list :: [(Name, [String])],

107 proof_list :: [(Name, [String])],

102 errLine :: Maybe Int,

108 errLine :: Maybe Int,

103 lastParse :: Maybe Name,

109 lastParse :: Maybe Name,

@@ -145,10 +151,10 @@ data IBCWrite = IBCFix FixDecl

145 | IBCSyntax Syntax

151 | IBCSyntax Syntax

146 | IBCKeyword String

152 | IBCKeyword String

147 | IBCImport FilePath

153 | IBCImport FilePath

148− | IBCObj Target FilePath

154+ | IBCObj Codegen FilePath

149− | IBCLib Target String

155+ | IBCLib Codegen String

150 | IBCDyLib String

156 | IBCDyLib String

151− | IBCHeader Target String

157+ | IBCHeader Codegen String

152 | IBCAccess Name Accessibility

158 | IBCAccess Name Accessibility

153 | IBCTotal Name Totality

159 | IBCTotal Name Totality

154 | IBCFlags Name [FnOpt]

160 | IBCFlags Name [FnOpt]

@@ -171,12 +177,12 @@ type Idris = StateT IState IO

171

177

172-- Commands in the REPL

178-- Commands in the REPL

173

179

174−data Target = ViaC

180+data Codegen = ViaC

175− | ViaJava

181+ | ViaJava

176− | ViaNode

182+ | ViaNode

177− | ViaJavaScript

183+ | ViaJavaScript

178− | ViaLLVM

184+ | ViaLLVM

179− | Bytecode

185+ | Bytecode

180 deriving (Show, Eq)

186 deriving (Show, Eq)

181

187

182-- | REPL commands

188-- | REPL commands

@@ -191,7 +197,7 @@ data Command = Quit

191 | ChangeDirectory FilePath

197 | ChangeDirectory FilePath

192 | ModImport String

198 | ModImport String

193 | Edit

199 | Edit

194− | Compile Target String

200+ | Compile Codegen String

195 | Execute

201 | Execute

196 | ExecVal PTerm

202 | ExecVal PTerm

197 | NewCompile String

203 | NewCompile String

@@ -251,10 +257,13 @@ data Opt = Filename String

251 | DumpDefun String

257 | DumpDefun String

252 | DumpCases String

258 | DumpCases String

253 | FOVM String

259 | FOVM String

254− | UseTarget Target

260+ | UseCodegen Codegen

255 | OutputTy OutputType

261 | OutputTy OutputType

256 | Extension LanguageExt

262 | Extension LanguageExt

257 | InterpretScript String

263 | InterpretScript String

264+ | TargetTriple String

265+ | TargetCPU String

266+ | OptLevel Int

258 deriving (Show, Eq)

267 deriving (Show, Eq)

259

268

260-- Parsed declarations

269-- Parsed declarations

src/Idris/IBC.hs+8−8

@@ -39,10 +39,10 @@ data IBCFile = IBCFile { ver :: Word8,

39 ibc_optimise :: [(Name, OptInfo)],

40 ibc_syntax :: [Syntax],

41 ibc_keywords :: [String],

42− ibc_objs :: [(Target, FilePath)],

42+ ibc_objs :: [(Codegen, FilePath)],

43− ibc_libs :: [(Target, String)],

43+ ibc_libs :: [(Codegen, String)],

44 ibc_dynamic_libs :: [String],

45− ibc_hdrs :: [(Target, String)],

45+ ibc_hdrs :: [(Codegen, String)],

46 ibc_access :: [(Name, Accessibility)],

47 ibc_total :: [(Name, Totality)],

48 ibc_flags :: [(Name, [FnOpt])],

@@ -244,10 +244,10 @@ pKeywords :: [String] -> Idris ()

244pKeywords k = do i <- getIState

245 putIState (i { syntax_keywords = k ++ syntax_keywords i })

246

247−pObjs :: [(Target, FilePath)] -> Idris ()

247+pObjs :: [(Codegen, FilePath)] -> Idris ()

248pObjs os = mapM_ (uncurry addObjectFile) os

249

250−pLibs :: [(Target, String)] -> Idris ()

250+pLibs :: [(Codegen, String)] -> Idris ()

251pLibs ls = mapM_ (uncurry addLib) ls

252

253pDyLibs :: [String] -> Idris ()

@@ -257,7 +257,7 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

257 where checkLoad (Left _) = return ()

258 checkLoad (Right err) = fail err

259

260−pHdrs :: [(Target, String)] -> Idris ()

260+pHdrs :: [(Codegen, String)] -> Idris ()

261pHdrs hs = mapM_ (uncurry addHdr) hs

262

263pDefs :: [(Name, Def)] -> Idris ()

@@ -1695,7 +1695,7 @@ instance Binary SSymbol where

1695 return (Binding x1)

1696 _ -> error "Corrupted binary data for SSymbol"

1697

1698−instance Binary Target where

1698+instance Binary Codegen where

1699 put x

1700 = case x of

1701 ViaC -> putWord8 0

@@ -1711,5 +1711,5 @@ instance Binary Target where

1711 2 -> return ViaNode

1712 3 -> return ViaJavaScript

1713 4 -> return Bytecode

1714− _ -> error "Corrupted binary data for Target"

1714+ _ -> error "Corrupted binary data for Codegen"

1715

src/Idris/Parser.hs+16−15

@@ -1539,25 +1539,26 @@ pWhereblock n syn

1539 closeBlock

1540 return (concat ds, map (\x -> (x, decoration syn x)) dns)

1541

1542−pTarget :: IParser Target

1542+pCodegen :: IParser Codegen

1543−pTarget = try (do reserved "C"; return ViaC)

1543+pCodegen = try (do reserved "C"; return ViaC)

1544− <|> try (do reserved "Java"; return ViaJava)

1544+ <|> try (do reserved "Java"; return ViaJava)

1545− <|> try (do reserved "JavaScript"; return ViaJavaScript)

1545+ <|> try (do reserved "JavaScript"; return ViaJavaScript)

1546− <|> try (do reserved "Node"; return ViaNode)

1546+ <|> try (do reserved "Node"; return ViaNode)

1547+ <|> try (do reserved "LLVM"; return ViaLLVM)

1547− <|> try (do reserved "Bytecode"; return Bytecode)

1548+ <|> try (do reserved "Bytecode"; return Bytecode)

1548

1549

1549pDirective :: SyntaxInfo -> IParser [PDecl]

1550pDirective :: SyntaxInfo -> IParser [PDecl]

1550−pDirective syn = try (do lchar '%'; reserved "lib"; tgt <- pTarget; lib <- strlit;

1551+pDirective syn = try (do lchar '%'; reserved "lib"; cgn <- pCodegen; lib <- strlit;

1551− return [PDirective (do addLib tgt lib

1552+ return [PDirective (do addLib cgn lib

1552− addIBC (IBCLib tgt lib))])

1553+ addIBC (IBCLib cgn lib))])

1553− <|> try (do lchar '%'; reserved "link"; tgt <- pTarget; obj <- strlit;

1554+ <|> try (do lchar '%'; reserved "link"; cgn <- pCodegen; obj <- strlit;

1554 return [PDirective (do datadir <- liftIO getDataDir

1555 return [PDirective (do datadir <- liftIO getDataDir

1555 o <- liftIO $ findInPath [".", datadir] obj

1556 o <- liftIO $ findInPath [".", datadir] obj

1556− addIBC (IBCObj tgt o)

1557+ addIBC (IBCObj cgn o)

1557− addObjectFile tgt o)])

1558+ addObjectFile cgn o)])

1558− <|> try (do lchar '%'; reserved "include"; tgt <- pTarget; hdr <- strlit;

1559+ <|> try (do lchar '%'; reserved "include"; cgn <- pCodegen; hdr <- strlit;

1559− return [PDirective (do addHdr tgt hdr

1560+ return [PDirective (do addHdr cgn hdr

1560− addIBC (IBCHeader tgt hdr))])

1561+ addIBC (IBCHeader cgn hdr))])

1561 <|> try (do lchar '%'; reserved "hide"; n <- iName []

1562 <|> try (do lchar '%'; reserved "hide"; n <- iName []

1562 return [PDirective (do setAccessibility n Hidden

1563 return [PDirective (do setAccessibility n Hidden

1563 addIBC (IBCAccess n Hidden))])

1564 addIBC (IBCAccess n Hidden))])

src/Idris/REPL.hs+54−21

@@ -39,6 +39,8 @@ import IRTS.CodegenCommon

39-- import RTS.PreC

40-- import RTS.CodegenC

42+import LLVM.General.Target

43+

42import System.Console.Haskeline as H

44import System.Console.Haskeline as H

43import System.FilePath

45import System.FilePath

44import System.Exit

46import System.Exit

@@ -155,8 +157,8 @@ ideslaveProcess fn Execute = do process fn Execute

155 iResult ""

157 iResult ""

156ideslaveProcess fn (NewCompile f) = do process fn (NewCompile f)

158ideslaveProcess fn (NewCompile f) = do process fn (NewCompile f)

157 iResult ""

159 iResult ""

158−ideslaveProcess fn (Compile target f) = do process fn (Compile target f)

160+ideslaveProcess fn (Compile codegen f) = do process fn (Compile codegen f)

159− iResult ""

161+ iResult ""

160ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i)

162ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i)

161 iResult ""

163 iResult ""

162ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)

164ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)

@@ -465,7 +467,7 @@ process fn Execute = do (m, _) <- elabVal toplevel False

465-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

467-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

466 (tmpn, tmph) <- liftIO tempfile

468 (tmpn, tmph) <- liftIO tempfile

467 liftIO $ hClose tmph

469 liftIO $ hClose tmph

468− t <- target

470+ t <- codegen

469 compile t tmpn m

471 compile t tmpn m

470 liftIO $ system tmpn

472 liftIO $ system tmpn

471 return ()

473 return ()

@@ -476,11 +478,11 @@ process fn (NewCompile f)

476 [pexp $ PRef fc (NS (UN "main") ["Main"])])

478 [pexp $ PRef fc (NS (UN "main") ["Main"])])

477 compileEpic f m

479 compileEpic f m

478 where fc = FC "main" 0

480 where fc = FC "main" 0

479−process fn (Compile target f)

481+process fn (Compile codegen f)

480 = do (m, _) <- elabVal toplevel False

482 = do (m, _) <- elabVal toplevel False

481 (PApp fc (PRef fc (UN "run__IO"))

483 (PApp fc (PRef fc (UN "run__IO"))

482 [pexp $ PRef fc (NS (UN "main") ["Main"])])

484 [pexp $ PRef fc (NS (UN "main") ["Main"])])

483− compile target f m

485+ compile codegen f m

484 where fc = FC "main" 0

486 where fc = FC "main" 0

485process fn (LogLvl i) = setLogLevel i

487process fn (LogLvl i) = setLogLevel i

486-- Elaborate as if LHS of a pattern (debug command)

488-- Elaborate as if LHS of a pattern (debug command)

@@ -560,14 +562,14 @@ displayHelp = let vstr = showVersion version in

560 l ++ take (c1 - length l) (repeat ' ') ++

562 l ++ take (c1 - length l) (repeat ' ') ++

561 m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n"

563 m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n"

562

564

563−parseTarget :: String -> Target

565+parseCodegen :: String -> Codegen

564−parseTarget "C" = ViaC

566+parseCodegen "C" = ViaC

565−parseTarget "Java" = ViaJava

567+parseCodegen "Java" = ViaJava

566−parseTarget "bytecode" = Bytecode

568+parseCodegen "bytecode" = Bytecode

567−parseTarget "javascript" = ViaJavaScript

569+parseCodegen "javascript" = ViaJavaScript

568−parseTarget "node" = ViaNode

570+parseCodegen "node" = ViaNode

569−parseTarget "llvm" = ViaLLVM

571+parseCodegen "llvm" = ViaLLVM

570−parseTarget _ = error "unknown target" -- FIXME: partial function

572+parseCodegen _ = error "unknown codegen" -- FIXME: partial function

571

573

572parseArgs :: [String] -> [Opt]

574parseArgs :: [String] -> [Opt]

573parseArgs [] = []

575parseArgs [] = []

@@ -605,10 +607,17 @@ parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)

605parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

607parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)

606parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns)

608parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns)

607parseArgs ("--dumpcases":n:ns) = DumpCases n : (parseArgs ns)

609parseArgs ("--dumpcases":n:ns) = DumpCases n : (parseArgs ns)

608−parseArgs ("--target":n:ns) = UseTarget (parseTarget n) : (parseArgs ns)

610+parseArgs ("--codegen":n:ns) = UseCodegen (parseCodegen n) : (parseArgs ns)

609parseArgs ["--exec"] = InterpretScript "Main.main" : []

611parseArgs ["--exec"] = InterpretScript "Main.main" : []

610parseArgs ("--exec":expr:ns) = InterpretScript expr : parseArgs ns

612parseArgs ("--exec":expr:ns) = InterpretScript expr : parseArgs ns

611parseArgs ("-XTypeProviders":ns) = Extension TypeProviders : (parseArgs ns)

613parseArgs ("-XTypeProviders":ns) = Extension TypeProviders : (parseArgs ns)

614+parseArgs ("-O3":ns) = OptLevel 3 : parseArgs ns

615+parseArgs ("-O2":ns) = OptLevel 2 : parseArgs ns

616+parseArgs ("-O1":ns) = OptLevel 1 : parseArgs ns

617+parseArgs ("-O0":ns) = OptLevel 0 : parseArgs ns

618+parseArgs ("-O":n:ns) = OptLevel (read n) : parseArgs ns

619+parseArgs ("--target":n:ns) = TargetTriple n : parseArgs ns

620+parseArgs ("--cpu":n:ns) = TargetCPU n : parseArgs ns

612parseArgs (n:ns) = Filename n : (parseArgs ns)

621parseArgs (n:ns) = Filename n : (parseArgs ns)

613

622

614helphead =

623helphead =

@@ -637,10 +646,19 @@ idrisMain opts =

637 let bcs = opt getBC opts

646 let bcs = opt getBC opts

638 let vm = opt getFOVM opts

647 let vm = opt getFOVM opts

639 let pkgdirs = opt getPkgDir opts

648 let pkgdirs = opt getPkgDir opts

649+ let optimize = case opt getOptLevel opts of

650+ [] -> 2

651+ xs -> last xs

652+ trpl <- case opt getTriple opts of

653+ [] -> liftIO $ getDefaultTargetTriple

654+ xs -> return (last xs)

655+ tcpu <- case opt getCPU opts of

656+ [] -> liftIO $ getHostCPUName

657+ xs -> return (last xs)

640 let outty = case opt getOutputTy opts of

658 let outty = case opt getOutputTy opts of

641 [] -> Executable

659 [] -> Executable

642 xs -> last xs

660 xs -> last xs

643− let tgt = case opt getTarget opts of

661+ let cgn = case opt getCodegen opts of

644 [] -> ViaC

662 [] -> ViaC

645 xs -> last xs

663 xs -> last xs

646 script <- case opt getExecScript opts of

664 script <- case opt getExecScript opts of

@@ -657,13 +675,16 @@ idrisMain opts =

657 setVerbose runrepl

675 setVerbose runrepl

658 setCmdLine opts

676 setCmdLine opts

659 setOutputTy outty

677 setOutputTy outty

660− setTarget tgt

678+ setCodegen cgn

679+ setTargetTriple trpl

680+ setTargetCPU tcpu

681+ setOptLevel optimize

661 when (Verbose `elem` opts) $ setVerbose True

682 when (Verbose `elem` opts) $ setVerbose True

662 mapM_ makeOption opts

683 mapM_ makeOption opts

663 -- if we have the --fovm flag, drop into the first order VM testing

684 -- if we have the --fovm flag, drop into the first order VM testing

664 case vm of

685 case vm of

665 [] -> return ()

686 [] -> return ()

666− xs -> liftIO $ mapM_ (fovm tgt outty) xs

687+ xs -> liftIO $ mapM_ (fovm cgn outty) xs

667 -- if we have the --bytecode flag, drop into the bytecode assembler

688 -- if we have the --bytecode flag, drop into the bytecode assembler

668 case bcs of

689 case bcs of

669 [] -> return ()

690 [] -> return ()

@@ -684,7 +705,7 @@ idrisMain opts =

684 ok <- noErrors

705 ok <- noErrors

685 when ok $ case output of

706 when ok $ case output of

686 [] -> return ()

707 [] -> return ()

687− (o:_) -> process "" (Compile tgt o)

708+ (o:_) -> process "" (Compile cgn o)

688 when ok $ case newoutput of

709 when ok $ case newoutput of

689 [] -> return ()

710 [] -> return ()

690 (o:_) -> process "" (NewCompile o)

711 (o:_) -> process "" (NewCompile o)

@@ -758,9 +779,9 @@ getPkgClean :: Opt -> Maybe String

758getPkgClean (PkgClean str) = Just str

779getPkgClean (PkgClean str) = Just str

759getPkgClean _ = Nothing

780getPkgClean _ = Nothing

760

781

761−getTarget :: Opt -> Maybe Target

782+getCodegen :: Opt -> Maybe Codegen

762−getTarget (UseTarget x) = Just x

783+getCodegen (UseCodegen x) = Just x

763−getTarget _ = Nothing

784+getCodegen _ = Nothing

764

785

765getExecScript :: Opt -> Maybe String

786getExecScript :: Opt -> Maybe String

766getExecScript (InterpretScript expr) = Just expr

787getExecScript (InterpretScript expr) = Just expr

@@ -774,6 +795,18 @@ getLanguageExt :: Opt -> Maybe LanguageExt

774getLanguageExt (Extension e) = Just e

795getLanguageExt (Extension e) = Just e

775getLanguageExt _ = Nothing

796getLanguageExt _ = Nothing

776

797

798+getTriple :: Opt -> Maybe String

799+getTriple (TargetTriple x) = Just x

800+getTriple _ = Nothing

801+

802+getCPU :: Opt -> Maybe String

803+getCPU (TargetCPU x) = Just x

804+getCPU _ = Nothing

805+

806+getOptLevel :: Opt -> Maybe Int

807+getOptLevel (OptLevel x) = Just x

808+getOptLevel _ = Nothing

809+

777opt :: (Opt -> Maybe a) -> [Opt] -> [a]

810opt :: (Opt -> Maybe a) -> [Opt] -> [a]

778opt = mapMaybe

811opt = mapMaybe

779

812

test/Makefile+49−49

@@ -2,57 +2,57 @@ test:

2 perl ./runtest.pl all

4test_java:

5− perl ./runtest.pl all --target Java

5+ perl ./runtest.pl all --codegen Java

7test_js:

8− @perl ./runtest.pl reg001 --target node

8+ @perl ./runtest.pl reg001 --codegen node

9− @perl ./runtest.pl reg002 --target node

9+ @perl ./runtest.pl reg002 --codegen node

10− @perl ./runtest.pl reg003 --target node

10+ @perl ./runtest.pl reg003 --codegen node

11− @perl ./runtest.pl reg004 --target node

11+ @perl ./runtest.pl reg004 --codegen node

12− @perl ./runtest.pl reg004 --target node

12+ @perl ./runtest.pl reg004 --codegen node

13− @perl ./runtest.pl reg005 --target node

13+ @perl ./runtest.pl reg005 --codegen node

14− @perl ./runtest.pl reg006 --target node

14+ @perl ./runtest.pl reg006 --codegen node

15− @perl ./runtest.pl reg007 --target node

15+ @perl ./runtest.pl reg007 --codegen node

16− @perl ./runtest.pl reg008 --target node

16+ @perl ./runtest.pl reg008 --codegen node

17− @perl ./runtest.pl reg009 --target node

17+ @perl ./runtest.pl reg009 --codegen node

18− @perl ./runtest.pl reg010 --target node

18+ @perl ./runtest.pl reg010 --codegen node

19− @perl ./runtest.pl reg011 --target node

19+ @perl ./runtest.pl reg011 --codegen node

20− @perl ./runtest.pl reg012 --target node

20+ @perl ./runtest.pl reg012 --codegen node

21− @perl ./runtest.pl reg013 --target node

21+ @perl ./runtest.pl reg013 --codegen node

22− @perl ./runtest.pl reg014 --target node

22+ @perl ./runtest.pl reg014 --codegen node

23− @perl ./runtest.pl reg015 --target node

23+ @perl ./runtest.pl reg015 --codegen node

24− @#perl ./runtest.pl reg016 --target node

24+ @#perl ./runtest.pl reg016 --codegen node

25− @perl ./runtest.pl reg017 --target node

25+ @perl ./runtest.pl reg017 --codegen node

26− @perl ./runtest.pl reg018 --target node

26+ @perl ./runtest.pl reg018 --codegen node

27− @perl ./runtest.pl reg019 --target node

27+ @perl ./runtest.pl reg019 --codegen node

28− @perl ./runtest.pl test001 --target node

28+ @perl ./runtest.pl test001 --codegen node

29− @perl ./runtest.pl test002 --target node

29+ @perl ./runtest.pl test002 --codegen node

30− @perl ./runtest.pl test003 --target node

30+ @perl ./runtest.pl test003 --codegen node

31− @#perl ./runtest.pl test004 --target node

31+ @#perl ./runtest.pl test004 --codegen node

32− @perl ./runtest.pl test005 --target node

32+ @perl ./runtest.pl test005 --codegen node

33− @perl ./runtest.pl test006 --target node

33+ @perl ./runtest.pl test006 --codegen node

34− @perl ./runtest.pl test007 --target node

34+ @perl ./runtest.pl test007 --codegen node

35− @perl ./runtest.pl test008 --target node

35+ @perl ./runtest.pl test008 --codegen node

36− @perl ./runtest.pl test009 --target node

36+ @perl ./runtest.pl test009 --codegen node

37− @perl ./runtest.pl test010 --target node

37+ @perl ./runtest.pl test010 --codegen node

38− @perl ./runtest.pl test011 --target node

38+ @perl ./runtest.pl test011 --codegen node

39− @perl ./runtest.pl test012 --target node

39+ @perl ./runtest.pl test012 --codegen node

40− @perl ./runtest.pl test013 --target node

40+ @perl ./runtest.pl test013 --codegen node

41− @#perl ./runtest.pl test014 --target node

41+ @#perl ./runtest.pl test014 --codegen node

42− @perl ./runtest.pl test015 --target node

42+ @perl ./runtest.pl test015 --codegen node

43− @perl ./runtest.pl test016 --target node

43+ @perl ./runtest.pl test016 --codegen node

44− @perl ./runtest.pl test017 --target node

44+ @perl ./runtest.pl test017 --codegen node

45− @#perl ./runtest.pl test018 --target node

45+ @#perl ./runtest.pl test018 --codegen node

46− @perl ./runtest.pl test019 --target node

46+ @perl ./runtest.pl test019 --codegen node

47− @perl ./runtest.pl test020 --target node

47+ @perl ./runtest.pl test020 --codegen node

48− @#perl ./runtest.pl test021 --target node

48+ @#perl ./runtest.pl test021 --codegen node

49− @perl ./runtest.pl test022 --target node

49+ @perl ./runtest.pl test022 --codegen node

50− @perl ./runtest.pl test023 --target node

50+ @perl ./runtest.pl test023 --codegen node

51− @perl ./runtest.pl test024 --target node

51+ @perl ./runtest.pl test024 --codegen node

52− @#perl ./runtest.pl test025 --target node

52+ @#perl ./runtest.pl test025 --codegen node

53− @perl ./runtest.pl test026 --target node

53+ @perl ./runtest.pl test026 --codegen node

54− @perl ./runtest.pl test027 --target node

54+ @perl ./runtest.pl test027 --codegen node

55− @perl ./runtest.pl test028 --target node

55+ @perl ./runtest.pl test028 --codegen node

57update:

58 perl ./runtest.pl all -u