git.iko.soy/Idris-dev
on master help sign in
Merge branch 'simd' of https://github.com/Ralith/Idris-dev into JavaRepairs
commit06a43e204d8bc16808882db49596b06c5fc945bd authorJan Bessai <Jan.Bessai@tu-dortmund.de> dateSat 6 Jul 2013, 00:37 (13 years ago) parent5067d7e8c02d2a
10 files changed+372−305
compare with master
unifiedsplit
idris.cabal+1−2 src/IRTS/CodegenLLVM.hs+157−165 src/IRTS/Compiler.hs+10−7 src/IRTS/LParser.hs+3−3 src/Idris/AbsSyntax.hs+49−19 src/Idris/AbsSyntaxTree.hs+25−16 src/Idris/IBC.hs+8−8 src/Idris/Parser.hs+16−15 src/Idris/REPL.hs+54−21 test/Makefile+49−49
idris.cabal+1−2
@@ -272,8 +272,7 @@ Executable idris
272272 haskeline>=0.7, split, directory,
273273 containers, process, transformers, filepath,
274274 directory, binary, bytestring, text, pretty,
275− language-java>=0.2.2, libffi, llvm-general>=3.3.0.6 && <3.4,
276− vector, vector-binary-instances
275+ language-java>=0.2.2, libffi, llvm-general==3.3.3.*
277276
278277 Extensions: MultiParamTypeClasses, FunctionalDependencies,
279278 FlexibleInstances, TemplateHaskell
src/IRTS/CodegenLLVM.hs+157−165
@@ -5,7 +5,6 @@ import IRTS.CodegenCommon
55import IRTS.Lang
66import IRTS.Simplified
77import qualified Core.TT as TT
8−import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)
98
109import Util.System
1110import Paths_idris
@@ -14,6 +13,9 @@ import LLVM.General.Context
1413import LLVM.General.Diagnostic
1514import LLVM.General.AST
1615import LLVM.General.AST.AddrSpace
16+import LLVM.General.Target
17+import LLVM.General.AST.DataLayout
18+import LLVM.General.PassManager
1719import qualified LLVM.General.Module as M
1820import qualified LLVM.General.AST.IntegerPredicate as IPred
1921import qualified LLVM.General.AST.Linkage as L
@@ -23,17 +25,21 @@ import qualified LLVM.General.AST.Attribute as A
2325import qualified LLVM.General.AST.Global as G
2426import qualified LLVM.General.AST.Constant as C
2527import 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
2631
2732import Data.List
2833import Data.Maybe
2934import Data.Word
3035import Data.Set (Set)
3136import qualified Data.Set as S
32−import qualified Data.Vector.Unboxed as V
37+import qualified Data.Map as M
3338import Control.Applicative
3439import Control.Monad.RWS
3540import Control.Monad.Writer
3641import Control.Monad.State
42+import Control.Monad.Error
3743
3844import qualified System.Info as SI (arch, os)
3945import System.IO
@@ -43,28 +49,46 @@ import System.Process (rawSystem)
4349import System.Exit (ExitCode(..))
4450import Debug.Trace
4551
46−data Target = Target { arch :: String, os :: String }
52+data Target = Target { triple :: String, dataLayout :: DataLayout }
4753
4854codegenLLVM :: [(TT.Name, SDecl)] ->
55+ String -> -- target triple
56+ String -> -- target CPU
57+ Int -> -- Optimization degree
4958 FilePath -> -- output file name
5059 OutputType ->
5160 IO ()
52−codegenLLVM defs file outty = withContext $ \context -> do
53− let target = Target { arch = SI.arch, os = SI.os }
54− let ast = codegen target (map snd defs)
55− result <- M.withModuleFromAST context ast (outputModule file outty)
56− case result of
57− Right _ -> return ()
58− Left msg -> ierror msg
59−
60−outputModule :: FilePath -> OutputType -> M.Module -> IO ()
61−outputModule file Raw m = M.writeBitcodeToFile file m
62−outputModule file Object m = withTmpFile $ \bc -> do
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
67− outputModule obj Object m
61+codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do
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
67+ let ast = codegen (Target triple layout) (map snd defs)
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
76+ case result of
77+ Right _ -> return ()
78+ Left msg -> ierror msg
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+
87+outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
88+outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
89+outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
90+outputModule tm file Executable m = withTmpFile $ \obj -> do
91+ outputModule tm obj Object m
6892 cc <- getCC
6993 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
7094 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
@@ -125,10 +149,10 @@ initDefs tgt =
125149 }
126150 , rtsFun "intStr" ptrI8 [IntegerType 64]
127151 [ 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)]
129153 , UnName 2 := simpleCall "snprintf"
130154 [ LocalReference (UnName 1)
131− , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)
155+ , ConstantOperand (C.Int (tgtWordSize tgt) 21)
132156 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
133157 , LocalReference (UnName 0)
134158 ]
@@ -136,10 +160,12 @@ initDefs tgt =
136160 (Do $ Ret (Just (LocalReference (UnName 1))) [])
137161 ]
138162 , 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
139166 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
140167 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
141168 , exfun "strlen" intPtr [ptrI8] False
142− , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
143169 , exfun "GC_init" VoidType [] False
144170 , exfun "GC_malloc" ptrI8 [intPtr] False
145171 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
@@ -167,7 +193,7 @@ initDefs tgt =
167193 , GlobalDefinition mainDef
168194 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
169195 where
170− intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
196+ intPtr = IntegerType (tgtWordSize tgt)
171197 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
172198 pmpz = PointerType mpzTy (AddrSpace 0)
173199
@@ -193,18 +219,24 @@ initDefs tgt =
193219 exVar :: String -> Type -> Definition
194220 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
195221
196− stdinName :: Target -> String
197− stdinName (Target { os = "darwin" }) = "__stdinp"
198− stdinName _ = "stdin"
199− stdoutName :: Target -> String
200− stdoutName (Target { os = "darwin" }) = "__stdoutp"
201− stdoutName _ = "stdout"
202− stderrName :: Target -> String
203− stderrName (Target { os = "darwin" }) = "__stderrp"
204− stderrName _ = "stderr"
222+isApple :: Target -> Bool
223+isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
224+
225+stdinName, stdoutName, stderrName :: Target -> String
226+stdinName t | isApple t = "__stdinp"
227+stdinName _ = "stdin"
228+stdoutName t | isApple t = "__stdoutp"
229+stdoutName _ = "stdout"
230+stderrName t | isApple t = "__stderrp"
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
205237
206238codegen :: 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)
208240 where
209241 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
210242
@@ -363,13 +395,13 @@ alloc ty = do
363395sizeOf :: Type -> Codegen Operand
364396sizeOf ty = ConstantOperand . C.PtrToInt
365397 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
366− . IntegerType . fromIntegral <$> getWordSize
398+ . IntegerType <$> getWordSize
367399
368−tgtWordSize :: Target -> Integer
369−tgtWordSize (Target { arch = "i386" }) = 32
370−tgtWordSize (Target { arch = "x86_64" }) = 64
400+tgtWordSize :: Target -> Word32
401+tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
402+ fst . fromJust $ M.lookup (AddrSpace 0) l
371403
372−getWordSize :: Codegen Integer
404+getWordSize :: Codegen Word32
373405getWordSize = tgtWordSize <$> asks target
374406
375407cgExpr :: SExp -> Codegen (Maybe Operand)
@@ -554,7 +586,7 @@ cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
554586cgChainCase caseValPtr defExp alts = do
555587 let (caseTy, comparator) =
556588 case head alts of
557− SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp")
589+ SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")
558590 SConstCase (TT.Str _) _ -> (FString, "strcmp")
559591 caseVal <- unbox caseTy caseValPtr
560592 defBlockName <- getName "default"
@@ -680,11 +712,6 @@ cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
680712cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
681713cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
682714cgConst' (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−
688715cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
689716cgConst' (TT.Fl f) = C.Float (F.Double f)
690717cgConst' (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
692719cgConst' x = ierror $ "Unsupported constant: " ++ show x
693720
694721cgConst :: TT.Const -> Codegen Operand
695−cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)
696−cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)
697−cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)
698−cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed 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)
704−cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)
722+cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
723+cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
724+cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
725+cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
726+cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
727+cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
705728cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
706729cgConst c@(TT.Str s) = do
707730 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
@@ -713,7 +736,7 @@ cgConst c@(TT.BI i) = do
713736 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
714737 , ConstantOperand $ C.Int 32 10
715738 ]
716− box (FArith (ATInt ITBig)) mpz
739+ box (FInt ITBig) mpz
717740cgConst x = return $ ConstantOperand nullValue
718741
719742numDigits :: Integer -> Integer -> Integer
@@ -759,82 +782,72 @@ ffunDecl name rty argtys =
759782 }
760783
761784ftyToTy :: FType -> Type
762−ftyToTy (FArith (ATInt ITNative)) = IntegerType 32
763−ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)
764−ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)
765−ftyToTy (FArith (ATInt (ITVec e c)))
766− = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e))
785+ftyToTy (FInt ITNative) = IntegerType 32
786+ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
787+ftyToTy (FInt ty) = IntegerType (itWidth ty)
767788ftyToTy FChar = IntegerType 32
768789ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
769790ftyToTy FUnit = VoidType
770791ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
771−ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE
792+ftyToTy FDouble = FloatingPointType 64 IEEE
772793ftyToTy FAny = valueType
773794
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−
779795cgOp :: PrimFn -> [Operand] -> Codegen Operand
780796cgOp (LTrunc ITBig ity) [x] = do
781− nx <- unbox (FArith (ATInt ITBig)) x
797+ nx <- unbox (FInt ITBig) x
782798 val <- inst $ simpleCall "mpz_get_ull" [nx]
783799 v <- case ity of
784− (ITFixed IT64) -> return val
785− _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []
786− box (FArith (ATInt ity)) v
800+ IT64 -> return val
801+ _ -> inst $ Trunc val (IntegerType $ itWidth ity) []
802+ box (FInt ity) v
787803cgOp (LZExt from ITBig) [x] = do
788− nx <- unbox (FArith (ATInt from)) x
804+ nx <- unbox (FInt from) x
789805 nx' <- case from of
790− (ITFixed IT64) -> return nx
806+ IT64 -> return nx
791807 _ -> inst $ ZExt nx (IntegerType 64) []
792808 mpz <- alloc mpzTy
793809 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
794− box (FArith (ATInt ITBig)) mpz
810+ box (FInt ITBig) mpz
795811cgOp (LSExt from ITBig) [x] = do
796− nx <- unbox (FArith (ATInt from)) x
812+ nx <- unbox (FInt from) x
797813 nx' <- case from of
798− (ITFixed IT64) -> return nx
814+ IT64 -> return nx
799815 _ -> inst $ SExt nx (IntegerType 64) []
800816 mpz <- alloc mpzTy
801817 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
802− box (FArith (ATInt ITBig)) mpz
803−
804−cgOp (LLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y
805−cgOp (LLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y
806−cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y
807−cgOp (LGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y
808−cgOp (LGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y
809−cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y
810−cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y
811−cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y
812−cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y
813−cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y
818+ box (FInt ITBig) mpz
819+
820+cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
821+cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
822+cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
823+cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y
824+cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y
825+cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y
826+cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y
827+cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y
828+cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y
829+cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y
814830cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
815831cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
816832cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
817833cgOp (LCompl ITBig) [x] = mpzUn "com" x
818834
819−cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]
820− | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x
821−cgOp (LZExt (ITFixed from) (ITFixed to)) [x]
822− | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x
823−cgOp (LSExt (ITFixed from) (ITFixed to)) [x]
824− | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x
825−
826−cgOp (LLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y
827−cgOp (LLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y
828−cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y
829−cgOp (LGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y
830−cgOp (LGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y
831−cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False)
832−cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False)
833−cgOp (LTimes (ATInt 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
835+cgOp (LTrunc from to) [x] | itWidth from > itWidth to = iCoerce Trunc from to x
836+cgOp (LZExt from to) [x] | itWidth from < itWidth to = iCoerce ZExt from to x
837+cgOp (LSExt from to) [x] | itWidth from < itWidth to = iCoerce SExt from to x
838+
839+cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y
840+cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y
841+cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y
842+cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y
843+cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y
844+cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
845+cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
846+cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
836847cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)
837848cgOp (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
838851cgOp (LAnd ity) [x,y] = ibin ity x y And
839852cgOp (LOr ity) [x,y] = ibin ity x y Or
840853cgOp (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)
843856cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)
844857cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)
845858
846−cgOp (LMkVec ety c) xs | c == length xs = do
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'
859+cgOp LNoOp xs = return $ last xs
866860
867861cgOp LStrEq [x,y] = do
868862 x' <- unbox FString x
@@ -870,7 +864,7 @@ cgOp LStrEq [x,y] = do
870864 cmp <- inst $ simpleCall "strcmp" [x', y']
871865 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
872866 val <- inst $ ZExt flag (IntegerType 32) []
873− box (FArith (ATInt (ITFixed IT32))) val
867+ box (FInt IT32) val
874868
875869cgOp LStrLt [x,y] = do
876870 nx <- unbox FString x
@@ -878,10 +872,10 @@ cgOp LStrLt [x,y] = do
878872 cmp <- inst $ simpleCall "strcmp" [nx, ny]
879873 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
880874 val <- inst $ ZExt flag (IntegerType 32) []
881− box (FArith (ATInt (ITFixed IT32))) val
875+ box (FInt IT32) val
882876
883877cgOp (LIntStr ITBig) [x] = do
884− x' <- unbox (FArith (ATInt ITBig)) x
878+ x' <- unbox (FInt ITBig) x
885879 ustr <- inst $ simpleCall "__gmpz_get_str"
886880 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
887881 , ConstantOperand (C.Int 32 10)
@@ -889,7 +883,7 @@ cgOp (LIntStr ITBig) [x] = do
889883 ]
890884 box FString ustr
891885cgOp (LIntStr ity) [x] = do
892− x' <- unbox (FArith (ATInt ity)) x
886+ x' <- unbox (FInt ity) x
893887 x'' <- if itWidth ity < 64
894888 then inst $ SExt x' (IntegerType 64) []
895889 else return x'
@@ -898,7 +892,7 @@ cgOp (LStrInt ITBig) [s] = do
898892 ns <- unbox FString s
899893 mpz <- alloc mpzTy
900894 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
901− box (FArith (ATInt ITBig)) mpz
895+ box (FInt ITBig) mpz
902896cgOp (LStrInt ity) [s] = do
903897 ns <- unbox FString s
904898 nx <- inst $ simpleCall "strtoll"
@@ -907,9 +901,9 @@ cgOp (LStrInt ity) [s] = do
907901 , ConstantOperand $ C.Int 32 10
908902 ]
909903 nx' <- case ity of
910− (ITFixed IT64) -> return nx
904+ IT64 -> return nx
911905 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
912− box (FArith (ATInt ity)) nx'
906+ box (FInt ity) nx'
913907
914908cgOp LStrConcat [x,y] = cgStrCat x y
915909
@@ -928,7 +922,7 @@ cgOp LStrHead [c] = do
928922
929923cgOp LStrIndex [s, i] = do
930924 ns <- unbox FString s
931− ni <- unbox (FArith (ATInt (ITFixed IT32))) i
925+ ni <- unbox (FInt IT32) i
932926 p <- inst $ GetElementPtr True ns [ni] []
933927 c <- inst $ Load False p Nothing 0 []
934928 c' <- inst $ ZExt c (IntegerType 32) []
@@ -945,9 +939,9 @@ cgOp LStrLen [s] = do
945939 ws <- getWordSize
946940 len' <- case ws of
947941 32 -> return len
948− x | x > 32 -> inst $ Trunc len (IntegerType $ fromInteger x) []
949− | x < 32 -> inst $ ZExt len (IntegerType $ fromInteger x) []
950− box (FArith (ATInt (ITFixed IT32))) len'
942+ x | x > 32 -> inst $ Trunc len (IntegerType 32) []
943+ | x < 32 -> inst $ ZExt len (IntegerType 32) []
944+ box (FInt IT32) len'
951945
952946cgOp LReadStr [p] = do
953947 np <- unbox FPtr p
@@ -955,24 +949,26 @@ cgOp LReadStr [p] = do
955949 box FString s
956950
957951cgOp LStdIn [] = do
958− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdin") Nothing 0 []
952+ stdin <- getStdIn
953+ ptr <- inst $ Load False stdin Nothing 0 []
959954 box FPtr ptr
960955cgOp LStdOut [] = do
961− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdout") Nothing 0 []
956+ stdout <- getStdOut
957+ ptr <- inst $ Load False stdout Nothing 0 []
962958 box FPtr ptr
963959cgOp LStdErr [] = do
964− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stderr") Nothing 0 []
960+ stdErr <- getStdErr
961+ ptr <- inst $ Load False stdErr Nothing 0 []
965962 box FPtr ptr
966963
967−
968964cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
969965 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
970966
971−iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand
967+iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> IntTy -> IntTy -> Operand -> Codegen Operand
972968iCoerce operator from to x = do
973− x' <- unbox (FArith (ATInt (ITFixed from))) x
974− x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed from)))) []
975− box (FArith (ATInt (ITFixed to))) x''
969+ x' <- unbox (FInt from) x
970+ x'' <- inst $ operator x' (IntegerType $ itWidth to) []
971+ box (FInt to) x''
976972
977973cgStrCat :: Operand -> Operand -> Codegen Operand
978974cgStrCat x y = do
@@ -981,7 +977,7 @@ cgStrCat x y = do
981977 xlen <- inst $ simpleCall "strlen" [x']
982978 ylen <- inst $ simpleCall "strlen" [y']
983979 zlen <- inst $ Add False True xlen ylen []
984− ws <- fromIntegral <$> getWordSize
980+ ws <- getWordSize
985981 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
986982 mem <- allocAtomic total
987983 inst $ simpleCall "memcpy" [mem, x', xlen]
@@ -998,54 +994,50 @@ cgStrCat x y = do
998994ibin :: IntTy -> Operand -> Operand
999995 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1000996ibin ity x y instCon = do
1001− nx <- unbox (FArith (ATInt ity)) x
1002− ny <- unbox (FArith (ATInt ity)) y
997+ nx <- unbox (FInt ity) x
998+ ny <- unbox (FInt ity) y
1003999 nr <- inst $ instCon nx ny []
1004− box (FArith (ATInt ity)) nr
1000+ box (FInt ity) nr
10051001
10061002iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
10071003iun ity x instCon = do
1008− nx <- unbox (FArith (ATInt ity)) x
1004+ nx <- unbox (FInt ity) x
10091005 nr <- inst $ instCon nx []
1010− box (FArith (ATInt ity)) nr
1006+ box (FInt ity) nr
10111007
10121008iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
10131009iCmp ity pred x y = do
1014− nx <- unbox (FArith (ATInt ity)) x
1015− ny <- unbox (FArith (ATInt ity)) y
1010+ nx <- unbox (FInt ity) x
1011+ ny <- unbox (FInt ity) y
10161012 nr <- inst $ ICmp pred nx ny []
1017− nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) []
1018− box (cmpResultTy ity) nr'
1019−
1020−cmpResultTy :: IntTy -> FType
1021−cmpResultTy v@(ITVec _ _) = FArith (ATInt v)
1022−cmpResultTy _ = FArith (ATInt (ITFixed IT32))
1013+ nr' <- inst $ ZExt nr (IntegerType 32) []
1014+ box (FInt IT32) nr'
10231015
10241016mpzBin :: String -> Operand -> Operand -> Codegen Operand
10251017mpzBin name x y = do
1026− nx <- unbox (FArith (ATInt ITBig)) x
1027− ny <- unbox (FArith (ATInt ITBig)) y
1018+ nx <- unbox (FInt ITBig) x
1019+ ny <- unbox (FInt ITBig) y
10281020 nz <- alloc mpzTy
10291021 inst' $ simpleCall "__gmpz_init" [nz]
10301022 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
1031− box (FArith (ATInt ITBig)) nz
1023+ box (FInt ITBig) nz
10321024
10331025mpzUn :: String -> Operand -> Codegen Operand
10341026mpzUn name x = do
1035− nx <- unbox (FArith (ATInt ITBig)) x
1027+ nx <- unbox (FInt ITBig) x
10361028 nz <- alloc mpzTy
10371029 inst' $ simpleCall "__gmpz_init" [nz]
10381030 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
1039− box (FArith (ATInt ITBig)) nz
1031+ box (FInt ITBig) nz
10401032
10411033mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
10421034mpzCmp pred x y = do
1043− nx <- unbox (FArith (ATInt ITBig)) x
1044− ny <- unbox (FArith (ATInt ITBig)) y
1035+ nx <- unbox (FInt ITBig) x
1036+ ny <- unbox (FInt ITBig) y
10451037 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
10461038 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
10471039 i <- inst $ ZExt result (IntegerType 32) []
1048− box (FArith (ATInt (ITFixed IT32))) i
1040+ box (FInt IT32) i
10491041
10501042simpleCall :: String -> [Operand] -> Instruction
10511043simpleCall name args =
src/IRTS/Compiler.hs+10−7
@@ -30,8 +30,8 @@ import System.FilePath ((</>), addTrailingPathSeparator)
3030
3131import Paths_idris
3232
33−compile :: Target -> FilePath -> Term -> Idris ()
34−compile target f tm
33+compile :: Codegen -> FilePath -> Term -> Idris ()
34+compile codegen f tm
3535 = do checkMVs
3636 let tmnames = namesUsed (STerm tm)
3737 usedIn <- mapM (allNames []) tmnames
@@ -39,9 +39,9 @@ compile target f tm
3939 defsIn <- mkDecls tm (concat used)
4040 findUnusedArgs (concat used)
4141 maindef <- irMain tm
42− objs <- getObjectFiles target
43− libs <- getLibs target
44− hdrs <- getHdrs target
42+ objs <- getObjectFiles codegen
43+ libs <- getLibs codegen
44+ hdrs <- getHdrs codegen
4545 let defs = defsIn ++ [(MN 0 "runMain", maindef)]
4646 -- iputStrLn $ showSep "\n" (map show defs)
4747 let (nexttag, tagged) = addTags 65536 (liftAll defs)
@@ -64,9 +64,12 @@ compile target f tm
6464 case dumpDefun of
6565 Nothing -> return ()
6666 Just f -> liftIO $ writeFile f (dumpDefuns defuns)
67+ triple <- targetTriple
68+ cpu <- targetCPU
69+ optimize <- optLevel
6770 iLOG "Building output"
6871 case checked of
69− OK c -> liftIO $ case target of
72+ OK c -> liftIO $ case codegen of
7073 ViaC ->
7174 codegenC c f outty hdrs
7275 (concatMap mkObj objs)
@@ -77,7 +80,7 @@ compile target f tm
7780 codegenJavaScript JavaScript c f outty
7881 ViaNode ->
7982 codegenJavaScript Node c f outty
80− ViaLLVM -> codegenLLVM c f outty
83+ ViaLLVM -> codegenLLVM c triple cpu optimize f outty
8184
8285 Bytecode -> dumpBC c f
8386 Error e -> fail $ show e
src/IRTS/LParser.hs+3−3
@@ -49,8 +49,8 @@ strlit = PTok.stringLiteral lexer
4949chlit = PTok.charLiteral lexer
5050lchar = lexeme.char
5151
52−fovm :: Target -> OutputType -> FilePath -> IO ()
53−fovm tgt outty f
52+fovm :: Codegen -> OutputType -> FilePath -> IO ()
53+fovm cgn outty f
5454 = do defs <- parseFOVM f
5555 let (nexttag, tagged) = addTags 0 (liftAll defs)
5656 ctxtIn = addAlist tagged emptyContext
@@ -59,7 +59,7 @@ fovm tgt outty f
5959 let checked = checkDefs defuns (toAlist defuns)
6060-- print checked
6161 case checked of
62− OK c -> case tgt of
62+ OK c -> case cgn of
6363 ViaC -> codegenC c "a.out" outty ["math.h"] "" "" TRACE
6464 ViaJava -> codegenJava [] c "a.out" [] [] outty
6565 Error e -> fail $ show e
src/Idris/AbsSyntax.hs+49−19
@@ -30,19 +30,19 @@ import Util.System
3030getContext :: Idris Context
3131getContext = do i <- getIState; return (tt_ctxt i)
3232
33−forTarget :: Target -> [(Target, a)] -> [a]
34−forTarget tgt xs = [x | (tgt', x) <- xs, tgt == tgt']
33+forCodegen :: Codegen -> [(Codegen, a)] -> [a]
34+forCodegen tgt xs = [x | (tgt', x) <- xs, tgt == tgt']
3535
36−getObjectFiles :: Target -> Idris [FilePath]
37−getObjectFiles tgt = do i <- getIState; return (forTarget tgt $ idris_objs i)
36+getObjectFiles :: Codegen -> Idris [FilePath]
37+getObjectFiles tgt = do i <- getIState; return (forCodegen tgt $ idris_objs i)
3838
39−addObjectFile :: Target -> FilePath -> Idris ()
39+addObjectFile :: Codegen -> FilePath -> Idris ()
4040addObjectFile tgt f = do i <- getIState; putIState $ i { idris_objs = (tgt, f) : idris_objs i }
4141
42−getLibs :: Target -> Idris [String]
43−getLibs tgt = do i <- getIState; return (forTarget tgt $ idris_libs i)
42+getLibs :: Codegen -> Idris [String]
43+getLibs tgt = do i <- getIState; return (forCodegen tgt $ idris_libs i)
4444
45−addLib :: Target -> String -> Idris ()
45+addLib :: Codegen -> String -> Idris ()
4646addLib tgt f = do i <- getIState; putIState $ i { idris_libs = (tgt, f) : idris_libs i }
4747
4848addDyLib :: [String] -> Idris (Either DynamicLib String)
@@ -55,7 +55,7 @@ addDyLib libs = do i <- getIState
5555 putIState $ i { idris_dynamic_libs = x:ls }
5656 return (Left x)
5757
58−addHdr :: Target -> String -> Idris ()
58+addHdr :: Codegen -> String -> Idris ()
5959addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = (tgt, f) : idris_hdrs i }
6060
6161addLangExt :: LanguageExt -> Idris ()
@@ -163,8 +163,8 @@ addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }
163163clearIBC :: Idris ()
164164clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }
165165
166−getHdrs :: Target -> Idris [String]
167−getHdrs tgt = do i <- getIState; return (forTarget tgt $ idris_hdrs i)
166+getHdrs :: Codegen -> Idris [String]
167+getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)
168168
169169setErrLine :: Int -> Idris ()
170170setErrLine x = do i <- getIState;
@@ -345,15 +345,15 @@ getQuiet = do i <- getIState
345345 let opts = idris_options i
346346 return (opt_quiet opts)
347347
348−setTarget :: Target -> Idris ()
349−setTarget t = do i <- getIState
350− let opts = idris_options i
351− let opt' = opts { opt_target = t }
352− putIState $ i { idris_options = opt' }
348+setCodegen :: Codegen -> Idris ()
349+setCodegen t = do i <- getIState
350+ let opts = idris_options i
351+ let opt' = opts { opt_codegen = t }
352+ putIState $ i { idris_options = opt' }
353353
354−target :: Idris Target
355−target = do i <- getIState
356− return (opt_target (idris_options i))
354+codegen :: Idris Codegen
355+codegen = do i <- getIState
356+ return (opt_codegen (idris_options i))
357357
358358setOutputTy :: OutputType -> Idris ()
359359setOutputTy t = do i <- getIState
@@ -370,6 +370,36 @@ setIdeSlave True = do i <- getIState
370370 putIState $ i { idris_outputmode = (IdeSlave 0) }
371371setIdeSlave False = return ()
372372
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+
373403verbose :: Idris Bool
374404verbose = do i <- getIState
375405 return (opt_verbose (idris_options i))
src/Idris/AbsSyntaxTree.hs+25−16
@@ -33,10 +33,13 @@ data IOption = IOption { opt_logLevel :: Int,
3333 opt_repl :: Bool,
3434 opt_verbose :: Bool,
3535 opt_quiet :: Bool,
36− opt_target :: Target,
36+ opt_codegen :: Codegen,
3737 opt_outputTy :: OutputType,
3838 opt_ibcsubdir :: FilePath,
3939 opt_importdirs :: [FilePath],
40+ opt_triple :: String,
41+ opt_cpu :: String,
42+ opt_optLevel :: Int,
4043 opt_cmdline :: [Opt] -- remember whole command line
4144 }
4245 deriving (Show, Eq)
@@ -50,10 +53,13 @@ defaultOpts = IOption { opt_logLevel = 0
5053 , opt_repl = True
5154 , opt_verbose = True
5255 , opt_quiet = False
53− , opt_target = ViaC
56+ , opt_codegen = ViaC
5457 , opt_outputTy = Executable
5558 , opt_ibcsubdir = ""
5659 , opt_importdirs = []
60+ , opt_triple = ""
61+ , opt_cpu = ""
62+ , opt_optLevel = 2
5763 , opt_cmdline = []
5864 }
5965
@@ -95,9 +101,9 @@ data IState = IState {
95101 syntax_keywords :: [String],
96102 imported :: [FilePath], -- ^ The imported modules
97103 idris_scprims :: [(Name, (Int, PrimFn))],
98− idris_objs :: [(Target, FilePath)],
99− idris_libs :: [(Target, String)],
100− idris_hdrs :: [(Target, String)],
104+ idris_objs :: [(Codegen, FilePath)],
105+ idris_libs :: [(Codegen, String)],
106+ idris_hdrs :: [(Codegen, String)],
101107 proof_list :: [(Name, [String])],
102108 errLine :: Maybe Int,
103109 lastParse :: Maybe Name,
@@ -145,10 +151,10 @@ data IBCWrite = IBCFix FixDecl
145151 | IBCSyntax Syntax
146152 | IBCKeyword String
147153 | IBCImport FilePath
148− | IBCObj Target FilePath
149− | IBCLib Target String
154+ | IBCObj Codegen FilePath
155+ | IBCLib Codegen String
150156 | IBCDyLib String
151− | IBCHeader Target String
157+ | IBCHeader Codegen String
152158 | IBCAccess Name Accessibility
153159 | IBCTotal Name Totality
154160 | IBCFlags Name [FnOpt]
@@ -171,12 +177,12 @@ type Idris = StateT IState IO
171177
172178-- Commands in the REPL
173179
174−data Target = ViaC
175− | ViaJava
176− | ViaNode
177− | ViaJavaScript
178− | ViaLLVM
179− | Bytecode
180+data Codegen = ViaC
181+ | ViaJava
182+ | ViaNode
183+ | ViaJavaScript
184+ | ViaLLVM
185+ | Bytecode
180186 deriving (Show, Eq)
181187
182188-- | REPL commands
@@ -191,7 +197,7 @@ data Command = Quit
191197 | ChangeDirectory FilePath
192198 | ModImport String
193199 | Edit
194− | Compile Target String
200+ | Compile Codegen String
195201 | Execute
196202 | ExecVal PTerm
197203 | NewCompile String
@@ -251,10 +257,13 @@ data Opt = Filename String
251257 | DumpDefun String
252258 | DumpCases String
253259 | FOVM String
254− | UseTarget Target
260+ | UseCodegen Codegen
255261 | OutputTy OutputType
256262 | Extension LanguageExt
257263 | InterpretScript String
264+ | TargetTriple String
265+ | TargetCPU String
266+ | OptLevel Int
258267 deriving (Show, Eq)
259268
260269-- Parsed declarations
src/Idris/IBC.hs+8−8
@@ -39,10 +39,10 @@ data IBCFile = IBCFile { ver :: Word8,
3939 ibc_optimise :: [(Name, OptInfo)],
4040 ibc_syntax :: [Syntax],
4141 ibc_keywords :: [String],
42− ibc_objs :: [(Target, FilePath)],
43− ibc_libs :: [(Target, String)],
42+ ibc_objs :: [(Codegen, FilePath)],
43+ ibc_libs :: [(Codegen, String)],
4444 ibc_dynamic_libs :: [String],
45− ibc_hdrs :: [(Target, String)],
45+ ibc_hdrs :: [(Codegen, String)],
4646 ibc_access :: [(Name, Accessibility)],
4747 ibc_total :: [(Name, Totality)],
4848 ibc_flags :: [(Name, [FnOpt])],
@@ -244,10 +244,10 @@ pKeywords :: [String] -> Idris ()
244244pKeywords k = do i <- getIState
245245 putIState (i { syntax_keywords = k ++ syntax_keywords i })
246246
247−pObjs :: [(Target, FilePath)] -> Idris ()
247+pObjs :: [(Codegen, FilePath)] -> Idris ()
248248pObjs os = mapM_ (uncurry addObjectFile) os
249249
250−pLibs :: [(Target, String)] -> Idris ()
250+pLibs :: [(Codegen, String)] -> Idris ()
251251pLibs ls = mapM_ (uncurry addLib) ls
252252
253253pDyLibs :: [String] -> Idris ()
@@ -257,7 +257,7 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls
257257 where checkLoad (Left _) = return ()
258258 checkLoad (Right err) = fail err
259259
260−pHdrs :: [(Target, String)] -> Idris ()
260+pHdrs :: [(Codegen, String)] -> Idris ()
261261pHdrs hs = mapM_ (uncurry addHdr) hs
262262
263263pDefs :: [(Name, Def)] -> Idris ()
@@ -1695,7 +1695,7 @@ instance Binary SSymbol where
16951695 return (Binding x1)
16961696 _ -> error "Corrupted binary data for SSymbol"
16971697
1698−instance Binary Target where
1698+instance Binary Codegen where
16991699 put x
17001700 = case x of
17011701 ViaC -> putWord8 0
@@ -1711,5 +1711,5 @@ instance Binary Target where
17111711 2 -> return ViaNode
17121712 3 -> return ViaJavaScript
17131713 4 -> return Bytecode
1714− _ -> error "Corrupted binary data for Target"
1714+ _ -> error "Corrupted binary data for Codegen"
17151715
src/Idris/Parser.hs+16−15
@@ -1539,25 +1539,26 @@ pWhereblock n syn
15391539 closeBlock
15401540 return (concat ds, map (\x -> (x, decoration syn x)) dns)
15411541
1542−pTarget :: IParser Target
1543−pTarget = try (do reserved "C"; return ViaC)
1544− <|> try (do reserved "Java"; return ViaJava)
1545− <|> try (do reserved "JavaScript"; return ViaJavaScript)
1546− <|> try (do reserved "Node"; return ViaNode)
1547− <|> try (do reserved "Bytecode"; return Bytecode)
1542+pCodegen :: IParser Codegen
1543+pCodegen = try (do reserved "C"; return ViaC)
1544+ <|> try (do reserved "Java"; return ViaJava)
1545+ <|> try (do reserved "JavaScript"; return ViaJavaScript)
1546+ <|> try (do reserved "Node"; return ViaNode)
1547+ <|> try (do reserved "LLVM"; return ViaLLVM)
1548+ <|> try (do reserved "Bytecode"; return Bytecode)
15481549
15491550pDirective :: SyntaxInfo -> IParser [PDecl]
1550−pDirective syn = try (do lchar '%'; reserved "lib"; tgt <- pTarget; lib <- strlit;
1551− return [PDirective (do addLib tgt lib
1552− addIBC (IBCLib tgt lib))])
1553− <|> try (do lchar '%'; reserved "link"; tgt <- pTarget; obj <- strlit;
1551+pDirective syn = try (do lchar '%'; reserved "lib"; cgn <- pCodegen; lib <- strlit;
1552+ return [PDirective (do addLib cgn lib
1553+ addIBC (IBCLib cgn lib))])
1554+ <|> try (do lchar '%'; reserved "link"; cgn <- pCodegen; obj <- strlit;
15541555 return [PDirective (do datadir <- liftIO getDataDir
15551556 o <- liftIO $ findInPath [".", datadir] obj
1556− addIBC (IBCObj tgt o)
1557− addObjectFile tgt o)])
1558− <|> try (do lchar '%'; reserved "include"; tgt <- pTarget; hdr <- strlit;
1559− return [PDirective (do addHdr tgt hdr
1560− addIBC (IBCHeader tgt hdr))])
1557+ addIBC (IBCObj cgn o)
1558+ addObjectFile cgn o)])
1559+ <|> try (do lchar '%'; reserved "include"; cgn <- pCodegen; hdr <- strlit;
1560+ return [PDirective (do addHdr cgn hdr
1561+ addIBC (IBCHeader cgn hdr))])
15611562 <|> try (do lchar '%'; reserved "hide"; n <- iName []
15621563 return [PDirective (do setAccessibility n Hidden
15631564 addIBC (IBCAccess n Hidden))])
src/Idris/REPL.hs+54−21
@@ -39,6 +39,8 @@ import IRTS.CodegenCommon
3939-- import RTS.PreC
4040-- import RTS.CodegenC
4141
42+import LLVM.General.Target
43+
4244import System.Console.Haskeline as H
4345import System.FilePath
4446import System.Exit
@@ -155,8 +157,8 @@ ideslaveProcess fn Execute = do process fn Execute
155157 iResult ""
156158ideslaveProcess fn (NewCompile f) = do process fn (NewCompile f)
157159 iResult ""
158−ideslaveProcess fn (Compile target f) = do process fn (Compile target f)
159− iResult ""
160+ideslaveProcess fn (Compile codegen f) = do process fn (Compile codegen f)
161+ iResult ""
160162ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i)
161163 iResult ""
162164ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)
@@ -465,7 +467,7 @@ process fn Execute = do (m, _) <- elabVal toplevel False
465467-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))
466468 (tmpn, tmph) <- liftIO tempfile
467469 liftIO $ hClose tmph
468− t <- target
470+ t <- codegen
469471 compile t tmpn m
470472 liftIO $ system tmpn
471473 return ()
@@ -476,11 +478,11 @@ process fn (NewCompile f)
476478 [pexp $ PRef fc (NS (UN "main") ["Main"])])
477479 compileEpic f m
478480 where fc = FC "main" 0
479−process fn (Compile target f)
481+process fn (Compile codegen f)
480482 = do (m, _) <- elabVal toplevel False
481483 (PApp fc (PRef fc (UN "run__IO"))
482484 [pexp $ PRef fc (NS (UN "main") ["Main"])])
483− compile target f m
485+ compile codegen f m
484486 where fc = FC "main" 0
485487process fn (LogLvl i) = setLogLevel i
486488-- Elaborate as if LHS of a pattern (debug command)
@@ -560,14 +562,14 @@ displayHelp = let vstr = showVersion version in
560562 l ++ take (c1 - length l) (repeat ' ') ++
561563 m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n"
562564
563−parseTarget :: String -> Target
564−parseTarget "C" = ViaC
565−parseTarget "Java" = ViaJava
566−parseTarget "bytecode" = Bytecode
567−parseTarget "javascript" = ViaJavaScript
568−parseTarget "node" = ViaNode
569−parseTarget "llvm" = ViaLLVM
570−parseTarget _ = error "unknown target" -- FIXME: partial function
565+parseCodegen :: String -> Codegen
566+parseCodegen "C" = ViaC
567+parseCodegen "Java" = ViaJava
568+parseCodegen "bytecode" = Bytecode
569+parseCodegen "javascript" = ViaJavaScript
570+parseCodegen "node" = ViaNode
571+parseCodegen "llvm" = ViaLLVM
572+parseCodegen _ = error "unknown codegen" -- FIXME: partial function
571573
572574parseArgs :: [String] -> [Opt]
573575parseArgs [] = []
@@ -605,10 +607,17 @@ parseArgs ("-S":ns) = OutputTy Raw : (parseArgs ns)
605607parseArgs ("-c":ns) = OutputTy Object : (parseArgs ns)
606608parseArgs ("--dumpdefuns":n:ns) = DumpDefun n : (parseArgs ns)
607609parseArgs ("--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)
609611parseArgs ["--exec"] = InterpretScript "Main.main" : []
610612parseArgs ("--exec":expr:ns) = InterpretScript expr : parseArgs ns
611613parseArgs ("-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
612621parseArgs (n:ns) = Filename n : (parseArgs ns)
613622
614623helphead =
@@ -637,10 +646,19 @@ idrisMain opts =
637646 let bcs = opt getBC opts
638647 let vm = opt getFOVM opts
639648 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)
640658 let outty = case opt getOutputTy opts of
641659 [] -> Executable
642660 xs -> last xs
643− let tgt = case opt getTarget opts of
661+ let cgn = case opt getCodegen opts of
644662 [] -> ViaC
645663 xs -> last xs
646664 script <- case opt getExecScript opts of
@@ -657,13 +675,16 @@ idrisMain opts =
657675 setVerbose runrepl
658676 setCmdLine opts
659677 setOutputTy outty
660− setTarget tgt
678+ setCodegen cgn
679+ setTargetTriple trpl
680+ setTargetCPU tcpu
681+ setOptLevel optimize
661682 when (Verbose `elem` opts) $ setVerbose True
662683 mapM_ makeOption opts
663684 -- if we have the --fovm flag, drop into the first order VM testing
664685 case vm of
665686 [] -> return ()
666− xs -> liftIO $ mapM_ (fovm tgt outty) xs
687+ xs -> liftIO $ mapM_ (fovm cgn outty) xs
667688 -- if we have the --bytecode flag, drop into the bytecode assembler
668689 case bcs of
669690 [] -> return ()
@@ -684,7 +705,7 @@ idrisMain opts =
684705 ok <- noErrors
685706 when ok $ case output of
686707 [] -> return ()
687− (o:_) -> process "" (Compile tgt o)
708+ (o:_) -> process "" (Compile cgn o)
688709 when ok $ case newoutput of
689710 [] -> return ()
690711 (o:_) -> process "" (NewCompile o)
@@ -758,9 +779,9 @@ getPkgClean :: Opt -> Maybe String
758779getPkgClean (PkgClean str) = Just str
759780getPkgClean _ = Nothing
760781
761−getTarget :: Opt -> Maybe Target
762−getTarget (UseTarget x) = Just x
763−getTarget _ = Nothing
782+getCodegen :: Opt -> Maybe Codegen
783+getCodegen (UseCodegen x) = Just x
784+getCodegen _ = Nothing
764785
765786getExecScript :: Opt -> Maybe String
766787getExecScript (InterpretScript expr) = Just expr
@@ -774,6 +795,18 @@ getLanguageExt :: Opt -> Maybe LanguageExt
774795getLanguageExt (Extension e) = Just e
775796getLanguageExt _ = Nothing
776797
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+
777810opt :: (Opt -> Maybe a) -> [Opt] -> [a]
778811opt = mapMaybe
779812
test/Makefile+49−49
@@ -2,57 +2,57 @@ test:
22 perl ./runtest.pl all
33
44test_java:
5− perl ./runtest.pl all --target Java
5+ perl ./runtest.pl all --codegen Java
66
77test_js:
8− @perl ./runtest.pl reg001 --target node
9− @perl ./runtest.pl reg002 --target node
10− @perl ./runtest.pl reg003 --target node
11− @perl ./runtest.pl reg004 --target node
12− @perl ./runtest.pl reg004 --target node
13− @perl ./runtest.pl reg005 --target node
14− @perl ./runtest.pl reg006 --target node
15− @perl ./runtest.pl reg007 --target node
16− @perl ./runtest.pl reg008 --target node
17− @perl ./runtest.pl reg009 --target node
18− @perl ./runtest.pl reg010 --target node
19− @perl ./runtest.pl reg011 --target node
20− @perl ./runtest.pl reg012 --target node
21− @perl ./runtest.pl reg013 --target node
22− @perl ./runtest.pl reg014 --target node
23− @perl ./runtest.pl reg015 --target node
24− @#perl ./runtest.pl reg016 --target node
25− @perl ./runtest.pl reg017 --target node
26− @perl ./runtest.pl reg018 --target node
27− @perl ./runtest.pl reg019 --target node
28− @perl ./runtest.pl test001 --target node
29− @perl ./runtest.pl test002 --target node
30− @perl ./runtest.pl test003 --target node
31− @#perl ./runtest.pl test004 --target node
32− @perl ./runtest.pl test005 --target node
33− @perl ./runtest.pl test006 --target node
34− @perl ./runtest.pl test007 --target node
35− @perl ./runtest.pl test008 --target node
36− @perl ./runtest.pl test009 --target node
37− @perl ./runtest.pl test010 --target node
38− @perl ./runtest.pl test011 --target node
39− @perl ./runtest.pl test012 --target node
40− @perl ./runtest.pl test013 --target node
41− @#perl ./runtest.pl test014 --target node
42− @perl ./runtest.pl test015 --target node
43− @perl ./runtest.pl test016 --target node
44− @perl ./runtest.pl test017 --target node
45− @#perl ./runtest.pl test018 --target node
46− @perl ./runtest.pl test019 --target node
47− @perl ./runtest.pl test020 --target node
48− @#perl ./runtest.pl test021 --target node
49− @perl ./runtest.pl test022 --target node
50− @perl ./runtest.pl test023 --target node
51− @perl ./runtest.pl test024 --target node
52− @#perl ./runtest.pl test025 --target node
53− @perl ./runtest.pl test026 --target node
54− @perl ./runtest.pl test027 --target node
55− @perl ./runtest.pl test028 --target node
8+ @perl ./runtest.pl reg001 --codegen node
9+ @perl ./runtest.pl reg002 --codegen node
10+ @perl ./runtest.pl reg003 --codegen node
11+ @perl ./runtest.pl reg004 --codegen node
12+ @perl ./runtest.pl reg004 --codegen node
13+ @perl ./runtest.pl reg005 --codegen node
14+ @perl ./runtest.pl reg006 --codegen node
15+ @perl ./runtest.pl reg007 --codegen node
16+ @perl ./runtest.pl reg008 --codegen node
17+ @perl ./runtest.pl reg009 --codegen node
18+ @perl ./runtest.pl reg010 --codegen node
19+ @perl ./runtest.pl reg011 --codegen node
20+ @perl ./runtest.pl reg012 --codegen node
21+ @perl ./runtest.pl reg013 --codegen node
22+ @perl ./runtest.pl reg014 --codegen node
23+ @perl ./runtest.pl reg015 --codegen node
24+ @#perl ./runtest.pl reg016 --codegen node
25+ @perl ./runtest.pl reg017 --codegen node
26+ @perl ./runtest.pl reg018 --codegen node
27+ @perl ./runtest.pl reg019 --codegen node
28+ @perl ./runtest.pl test001 --codegen node
29+ @perl ./runtest.pl test002 --codegen node
30+ @perl ./runtest.pl test003 --codegen node
31+ @#perl ./runtest.pl test004 --codegen node
32+ @perl ./runtest.pl test005 --codegen node
33+ @perl ./runtest.pl test006 --codegen node
34+ @perl ./runtest.pl test007 --codegen node
35+ @perl ./runtest.pl test008 --codegen node
36+ @perl ./runtest.pl test009 --codegen node
37+ @perl ./runtest.pl test010 --codegen node
38+ @perl ./runtest.pl test011 --codegen node
39+ @perl ./runtest.pl test012 --codegen node
40+ @perl ./runtest.pl test013 --codegen node
41+ @#perl ./runtest.pl test014 --codegen node
42+ @perl ./runtest.pl test015 --codegen node
43+ @perl ./runtest.pl test016 --codegen node
44+ @perl ./runtest.pl test017 --codegen node
45+ @#perl ./runtest.pl test018 --codegen node
46+ @perl ./runtest.pl test019 --codegen node
47+ @perl ./runtest.pl test020 --codegen node
48+ @#perl ./runtest.pl test021 --codegen node
49+ @perl ./runtest.pl test022 --codegen node
50+ @perl ./runtest.pl test023 --codegen node
51+ @perl ./runtest.pl test024 --codegen node
52+ @#perl ./runtest.pl test025 --codegen node
53+ @perl ./runtest.pl test026 --codegen node
54+ @perl ./runtest.pl test027 --codegen node
55+ @perl ./runtest.pl test028 --codegen node
5656
5757update:
5858 perl ./runtest.pl all -u