git.iko.soy/Idris-dev
on c1968ed help sign in
Idris-dev/src/IRTS/Compiler.hs
636 lines 23 kB history raw
1{-# LANGUAGE PatternGuards, TypeSynonymInstances, CPP #-}
3module IRTS.Compiler where
5import IRTS.Lang
6import IRTS.Defunctionalise
7import IRTS.Simplified
8import IRTS.CodegenCommon
9import IRTS.CodegenC
10import IRTS.CodegenJava
11import IRTS.DumpBC
12import IRTS.CodegenJavaScript
13#ifdef IDRIS_LLVM
14import IRTS.CodegenLLVM
15#else
16import Util.LLVMStubs
17#endif
18import IRTS.Inliner
20import Idris.AbsSyntax
21import Idris.AbsSyntaxTree
22import Idris.ASTUtils
23import Idris.Erasure
24import Idris.Error
26import Debug.Trace
28import Idris.Core.TT
29import Idris.Core.Evaluate
30import Idris.Core.CaseTree
32import Control.Category
33import Prelude hiding (id, (.))
35import Control.Applicative
36import Control.Monad.State
37import Data.Maybe
38import Data.List
39import Data.Ord
40import Data.IntSet (IntSet)
41import qualified Data.IntSet as IS
42import qualified Data.Map as M
43import qualified Data.Set as S
44import System.Process
45import System.IO
46import System.Directory
47import System.Environment
48import System.FilePath ((</>), addTrailingPathSeparator)
50compile :: Codegen -> FilePath -> Term -> Idris ()
51compile codegen f tm
52 = do checkMVs -- check for undefined metavariables
53 checkTotality -- refuse to compile if there are totality problems
54 reachableNames <- performUsageAnalysis
55 maindef <- irMain tm
56 iLOG $ "MAIN: " ++ show maindef
57 objs <- getObjectFiles codegen
58 libs <- getLibs codegen
59 flags <- getFlags codegen
60 hdrs <- getHdrs codegen
61 impdirs <- allImportDirs
62 defsIn <- mkDecls tm reachableNames
63 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]
64 -- iputStrLn $ showSep "\n" (map show defs)
65 let (nexttag, tagged) = addTags 65536 (liftAll defs)
66 let ctxtIn = addAlist tagged emptyContext
67 iLOG "Defunctionalising"
68 let defuns_in = defunctionalise nexttag ctxtIn
69 logLvl 5 $ show defuns_in
70 iLOG "Inlining"
71 let defuns = inline defuns_in
72 logLvl 5 $ show defuns
73 iLOG "Resolving variables for CG"
74 -- iputStrLn $ showSep "\n" (map show (toAlist defuns))
75 let checked = checkDefs defuns (toAlist defuns)
76 outty <- outputTy
77 dumpCases <- getDumpCases
78 dumpDefun <- getDumpDefun
79 case dumpCases of
80 Nothing -> return ()
81 Just f -> runIO $ writeFile f (showCaseTrees defs)
82 case dumpDefun of
83 Nothing -> return ()
84 Just f -> runIO $ writeFile f (dumpDefuns defuns)
85 triple <- Idris.AbsSyntax.targetTriple
86 cpu <- Idris.AbsSyntax.targetCPU
87 optimise <- optLevel
88 iLOG "Building output"
90 case checked of
91 OK c -> do let cginfo = CodegenInfo f outty triple cpu optimise
92 hdrs impdirs objs libs flags
93 NONE c (toAlist defuns)
94 tagged
95 runIO $ case codegen of
96 ViaC -> codegenC cginfo
97 ViaJava -> codegenJava cginfo
98 ViaJavaScript -> codegenJavaScript cginfo
99 ViaNode -> codegenNode cginfo
100 ViaLLVM -> codegenLLVM cginfo
101 Bytecode -> dumpBC c f
102 Error e -> ierror e
103 where checkMVs = do i <- getIState
104 case map fst (idris_metavars i) \\ primDefs of
105 [] -> return ()
106 ms -> ifail $ "There are undefined metavariables: " ++ show ms
107 checkTotality = do i <- getIState
108 case idris_totcheckfail i of
109 [] -> return ()
110 ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n " ++ msg
111 inDir d h = do let f = d </> h
112 ex <- doesFileExist f
113 if ex then return f else return h
115irMain :: TT Name -> Idris LDecl
116irMain tm = do
117 i <- irTerm M.empty [] tm
118 return $ LFun [] (sMN 0 "runMain") [] (LForce i)
120mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]
121mkDecls t used
122 = do i <- getIState
123 let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
124 decls <- mapM build ds
125 return decls
127showCaseTrees :: [(Name, LDecl)] -> String
128showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)
129 where
130 showCT (n, LFun _ f args lexp)
131 = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"
132 ++ show lexp
133 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a
135 defnRank :: (Name, LDecl) -> String
136 defnRank (n, LFun _ _ _ _) = "1" ++ nameRank n
137 defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n
139 nameRank :: Name -> String
140 nameRank (UN s) = "1" ++ show s
141 nameRank (MN i s) = "2" ++ show s ++ show i
142 nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n
143 nameRank (SN sn) = "4" ++ snRank sn
144 nameRank n = "5" ++ show n
146 snRank :: SpecialName -> String
147 snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i
148 snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args
149 snRank (ParentN n s) = "3" ++ nameRank n ++ show s
150 snRank (MethodN n) = "4" ++ nameRank n
151 snRank (CaseN n) = "5" ++ nameRank n
152 snRank (ElimN n) = "6" ++ nameRank n
153 snRank (InstanceCtorN n) = "7" ++ nameRank n
155isCon (TyDecl _ _) = True
156isCon _ = False
158build :: (Name, Def) -> Idris (Name, LDecl)
159build (n, d)
160 = do i <- getIState
161 case lookup n (idris_scprims i) of
162 Just (ar, op) ->
163 let args = map (\x -> sMN x "op") [0..] in
164 return (n, (LFun [] n (take ar args)
165 (LOp op (map (LV . Glob) (take ar args)))))
166 _ -> do def <- mkLDecl n d
167 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
168 return (n, def)
170declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x
171declArgs args inl n x = LFun (if inl then [Inline] else []) n args x
173mkLDecl n (Function tm _)
174 = declArgs [] True n <$> irTerm M.empty [] tm
176mkLDecl n (CaseOp ci _ _ _ pats cd)
177 = declArgs [] (case_inlinable ci) n <$> irTree args sc
178 where
179 (args, sc) = cases_runtime cd
181mkLDecl n (TyDecl (DCon tag arity) _) =
182 LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)
184mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a
185mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run
187data VarInfo = VI
188 { viMethod :: Maybe Name
189 }
190 deriving Show
192type Vars = M.Map Name VarInfo
194irTerm :: Vars -> [Name] -> Term -> Idris LExp
195irTerm vs env tm@(App f a) = case unApply tm of
196 (P _ (UN m) _, args)
197 | m == txt "mkForeignPrim"
198 -> doForeign vs env args
200 (P _ (UN u) _, [_, arg])
201 | u == txt "unsafePerformPrimIO"
202 -> irTerm vs env arg
204 -- TMP HACK - until we get inlining.
205 (P _ (UN r) _, [_, _, _, _, _, arg])
206 | r == txt "replace"
207 -> irTerm vs env arg
209 -- Laziness, the old way
210 (P _ (UN l) _, [_, arg])
211 | l == txt "lazy"
212 -> error "lazy has crept in somehow"
214 (P _ (UN l) _, [_, arg])
215 | l == txt "force"
216 -> LForce <$> irTerm vs env arg
218 -- Laziness, the new way
219 (P _ (UN l) _, [_, _, arg])
220 | l == txt "Delay"
221 -> LLazyExp <$> irTerm vs env arg
223 (P _ (UN l) _, [_, _, arg])
224 | l == txt "Force"
225 -> LForce <$> irTerm vs env arg
227 (P _ (UN a) _, [_, _, _, arg])
228 | a == txt "assert_smaller"
229 -> irTerm vs env arg
231 (P _ (UN a) _, [_, arg])
232 | a == txt "assert_total"
233 -> irTerm vs env arg
235 (P _ (UN p) _, [_, arg])
236 | p == txt "par"
237 -> do arg' <- irTerm vs env arg
238 return $ LOp LPar [LLazyExp arg']
240 (P _ (UN pf) _, [arg])
241 | pf == txt "prim_fork"
242 -> do arg' <- irTerm vs env arg
243 return $ LOp LFork [LLazyExp arg']
245 (P _ (UN m) _, [_,size,t])
246 | m == txt "malloc"
247 -> irTerm vs env t
249 (P _ (UN tm) _, [_,t])
250 | tm == txt "trace_malloc"
251 -> irTerm vs env t -- TODO
253 -- This case is here until we get more general inlining. It's just
254 -- a really common case, and the laziness hurts...
255 (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),
256 (App (App (App (P _ (UN d') _) _) _) e)])
257 | be == txt "boolElim"
258 , d == txt "Delay"
259 , d' == txt "Delay"
260 -> do
261 x' <- irTerm vs env x
262 t' <- irTerm vs env t
263 e' <- irTerm vs env e
264 return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'
265 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'
266 ])
268 -- data constructor
269 (P (DCon t arity) n _, args) -> do
270 detag <- fgetState (opt_detaggable . ist_optimisation n)
271 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
273 let isNewtype = length used == 1 && detag
274 let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]
276 -- The following code removes fields from data constructors
277 -- and performs the newtype optimisation.
278 --
279 -- The general rule here is:
280 -- Everything we get as input is not touched by erasure,
281 -- so it conforms to the official arities and types
282 -- and we can reason about it like it's plain TT.
283 --
284 -- It's only the data that leaves this point that's erased
285 -- and possibly no longer typed as the original TT version.
286 --
287 -- Especially, underapplied constructors must yield functions
288 -- even if all the remaining arguments are erased
289 -- (the resulting function *will* be applied, to NULLs).
290 --
291 -- This will probably need rethinking when we get erasure from functions.
293 -- "padLams" will wrap our term in LLam-bdas and give us
294 -- the "list of future unerased args" coming from these lambdas.
295 --
296 -- We can do whatever we like with the list of unerased args,
297 -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.
298 let padLams = padLambdas used (length args) arity
300 case compare arity (length args) of
302 -- overapplied
303 GT -> ifail ("overapplied data constructor: " ++ show tm)
305 -- exactly saturated
306 EQ | isNewtype
307 -> irTerm vs env (head argsPruned)
309 | otherwise -- not newtype, plain data ctor
310 -> buildApp (LV $ Glob n) argsPruned
312 -- not saturated, underapplied
313 LT | isNewtype -- newtype
314 , length argsPruned == 1 -- and we already have the value
315 -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args
316 <$> irTerm vs env (head argsPruned)
318 | isNewtype -- newtype but the value is not among args yet
319 -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]
321 -- not a newtype, just apply to a constructor
322 | otherwise
323 -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned
325 -- type constructor
326 (P (TCon t a) n _, args) -> return LNothing
328 -- a name applied to arguments
329 (P _ n _, args) -> do
330 ist <- getIState
331 case lookup n (idris_scprims ist) of
332 -- if it's a primitive that is already saturated,
333 -- compile to the corresponding op here already to save work
334 Just (arity, op) | length args == arity
335 -> LOp op <$> mapM (irTerm vs env) args
337 -- otherwise, just apply the name
338 _ -> applyName n ist args
340 -- turn de bruijn vars into regular named references and try again
341 (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args
343 (f, args)
344 -> LApp False
345 <$> irTerm vs env f
346 <*> mapM (irTerm vs env) args
348 where
349 buildApp :: LExp -> [Term] -> Idris LExp
350 buildApp e [] = return e
351 buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs
353 applyToNames :: LExp -> [Name] -> LExp
354 applyToNames tm [] = tm
355 applyToNames tm ns = LApp False tm $ map (LV . Glob) ns
357 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
358 padLambdas used startIdx endSIdx mkTerm
359 = LLam allNames $ mkTerm nonerasedNames
360 where
361 allNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]
362 nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]
364 applyName :: Name -> IState -> [Term] -> Idris LExp
365 applyName n ist args =
366 LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)
367 where
368 erase (i, x)
369 | i >= arity || i `elem` used = x
370 | otherwise = Erased
372 arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of
373 Just (CaseOp ci ty tys def tot cdefs) -> length tys
374 Just (TyDecl (DCon tag ar) _) -> ar
375 Just (TyDecl Ref ty) -> length $ getArgTys ty
376 Just (Operator ty ar op) -> ar
377 Just def -> error $ "unknown arity: " ++ show (n, def)
378 Nothing -> 0 -- no definition, probably local name => can't erase anything
380 -- name for purposes of usage info lookup
381 uName
382 | Just n' <- viMethod =<< M.lookup n vs = n'
383 | otherwise = n
385 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
386 fst4 (x,_,_,_) = x
388irTerm vs env (P _ n _) = return $ LV (Glob n)
389irTerm vs env (V i)
390 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
391 | otherwise = ifail $ "bad de bruijn index: " ++ show i
393irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc
394 where
395 n' = uniqueName n env
397irTerm vs env (Bind n (Let _ v) sc)
398 = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc
400irTerm vs env (Bind _ _ _) = return $ LNothing
402irTerm vs env (Proj t (-1)) = do
403 t' <- irTerm vs env t
404 return $ LOp (LMinus (ATInt ITBig))
405 [t', LConst (BI 1)]
407irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i
408irTerm vs env (Constant c) = return $ LConst c
409irTerm vs env (TType _) = return $ LNothing
410irTerm vs env Erased = return $ LNothing
411irTerm vs env Impossible = return $ LNothing
413doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp
414doForeign vs env (_ : fgn : args)
415 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
416 = case getFTypes fgnArgTys of
417 Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)
418 Just tys -> do
419 args' <- mapM (irTerm vs env) (init args)
420 return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')
422 | otherwise = ifail "Badly formed foreign function call"
423 where
424 getFTypes :: TT Name -> Maybe [FType]
425 getFTypes tm = case unApply tm of
426 -- nil : {a : Type} -> List a
427 (nil, [_]) -> Just []
428 -- cons : {a : Type} -> a -> List a -> List a
429 (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs
430 _ -> Nothing
432 mkIty' (P _ (UN ty) _) = mkIty (str ty)
433 mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))
434 | fi == txt "FIntT"
435 = mkIntIty (str intTy)
437 mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))
438 | ff == txt "FFunction"
439 , fa == txt "FAny"
440 , io == txt "IO"
441 = FFunctionIO
443 mkIty' (App (App (P _ (UN ff) _) _) _)
444 | ff == txt "FFunction"
445 = FFunction
447 mkIty' _ = FAny
449 -- would be better if these FInt types were evaluated at compile time
450 -- TODO: add %eval directive for such things
452 mkIty "FFloat" = FArith ATFloat
453 mkIty "FInt" = mkIntIty "ITNative"
454 mkIty "FChar" = mkIntIty "ITChar"
455 mkIty "FByte" = mkIntIty "IT8"
456 mkIty "FShort" = mkIntIty "IT16"
457 mkIty "FLong" = mkIntIty "IT64"
458 mkIty "FBits8" = mkIntIty "IT8"
459 mkIty "FBits16" = mkIntIty "IT16"
460 mkIty "FBits32" = mkIntIty "IT32"
461 mkIty "FBits64" = mkIntIty "IT64"
462 mkIty "FString" = FString
463 mkIty "FPtr" = FPtr
464 mkIty "FManagedPtr" = FManagedPtr
465 mkIty "FUnit" = FUnit
466 mkIty "FFunction" = FFunction
467 mkIty "FFunctionIO" = FFunctionIO
468 mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16))
469 mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8))
470 mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4))
471 mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2))
472 mkIty x = error $ "Unknown type " ++ x
474 mkIntIty "ITNative" = FArith (ATInt ITNative)
475 mkIntIty "ITChar" = FArith (ATInt ITChar)
476 mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))
477 mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))
478 mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))
479 mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))
481irTree :: [Name] -> SC -> Idris LExp
482irTree args tree = do
483 logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
484 LLam args <$> irSC M.empty tree
486irSC :: Vars -> SC -> Idris LExp
487irSC vs (STerm t) = irTerm vs [] t
488irSC vs (UnmatchedCase str) = return $ LError str
490irSC vs (ProjCase tm alts) = do
491 tm' <- irTerm vs [] tm
492 alts' <- mapM (irAlt vs tm') alts
493 return $ LCase tm' alts'
495-- Transform matching on Delay to applications of Force.
496irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])
497 | delay == txt "Delay"
498 = do sc' <- irSC vs $ mkForce n' n sc
499 return $ LLet n' (LForce (LV (Glob n))) sc'
501-- There are two transformations in this case:
502--
503-- 1. Newtype-case elimination:
504-- case {e0} of
505-- wrap({e1}) -> P({e1}) ==> P({e0})
506--
507-- This is important because newtyped constructors are compiled away entirely
508-- and we need to do that everywhere.
509--
510-- 2. Unused-case elimination (only valid for singleton branches):
511-- case {e0} of ==> P
512-- C(x,y) -> P[... x,y not used ...]
513--
514-- This is important for runtime because sometimes we case on irrelevant data:
515--
516-- In the example above, {e0} will most probably have been erased
517-- so this vain projection would make the resulting program segfault
518-- because the code generator still emits a PROJECT(...) G-machine instruction.
519--
520-- Hence, we check whether the variables are used at all
521-- and erase the casesplit if they are not.
522--
523irSC vs (Case n [alt]) = do
524 replacement <- case alt of
525 ConCase cn a ns sc -> do
526 detag <- fgetState (opt_detaggable . ist_optimisation cn)
527 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)
528 if detag && length used == 1
529 then return . Just $ substSC (ns !! head used) n sc
530 else return Nothing
531 _ -> return Nothing
533 case replacement of
534 Just sc -> irSC vs sc
535 _ -> do
536 alt' <- irAlt vs (LV (Glob n)) alt
537 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
538 [] -> subexpr alt' -- strip the unused top-most case
539 _ -> LCase (LV (Glob n)) [alt']
540 where
541 namesBoundIn :: LAlt -> [Name]
542 namesBoundIn (LConCase cn i ns sc) = ns
543 namesBoundIn (LConstCase c sc) = []
544 namesBoundIn (LDefaultCase sc) = []
546 subexpr :: LAlt -> LExp
547 subexpr (LConCase _ _ _ e) = e
548 subexpr (LConstCase _ e) = e
549 subexpr (LDefaultCase e) = e
551-- FIXME: When we have a non-singleton case-tree of the form
552--
553-- case {e0} of
554-- C(x) => ...
555-- ... => ...
556--
557-- and C is detaggable (the only constructor of the family), we can be sure
558-- that the first branch will be always taken -- so we add special handling
559-- to remove the dead default branch.
560--
561-- If we don't do so and C is newtype-optimisable, we will miss this newtype
562-- transformation and the resulting code will probably segfault.
563--
564-- This work-around is not entirely optimal; the best approach would be
565-- to ensure that such case trees don't arise in the first place.
566--
567irSC vs (Case n alts@[ConCase cn a ns sc, DefaultCase sc']) = do
568 detag <- fgetState (opt_detaggable . ist_optimisation cn)
569 if detag
570 then irSC vs (Case n [ConCase cn a ns sc])
571 else LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
573irSC vs sc@(Case n alts) = do
574 -- check that neither alternative needs the newtype optimisation,
575 -- see comment above
576 goneWrong <- or <$> mapM isDetaggable alts
577 when goneWrong
578 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
580 -- everything okay
581 LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
582 where
583 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
584 isDetaggable _ = return False
586irSC vs ImpossibleCase = return LNothing
588irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt
590-- this leaves out all unused arguments of the constructor
591irAlt vs _ (ConCase n t args sc) = do
592 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
593 let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]
594 LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc
595 where
596 methodVars = case n of
597 SN (InstanceCtorN className)
598 -> M.fromList [(v, VI
599 { viMethod = Just $ mkFieldName n i
600 }) | (v,i) <- zip args [0..]]
601 _
602 -> M.empty -- not an instance constructor
604irAlt vs _ (ConstCase x rhs)
605 | matchable x = LConstCase x <$> irSC vs rhs
606 | matchableTy x = LDefaultCase <$> irSC vs rhs
607 where
608 matchable (I _) = True
609 matchable (BI _) = True
610 matchable (Ch _) = True
611 matchable (Str _) = True
612 matchable _ = False
614 matchableTy (AType (ATInt ITNative)) = True
615 matchableTy (AType (ATInt ITBig)) = True
616 matchableTy (AType (ATInt ITChar)) = True
617 matchableTy StrType = True
619 matchableTy (AType (ATInt (ITFixed IT8))) = True
620 matchableTy (AType (ATInt (ITFixed IT16))) = True
621 matchableTy (AType (ATInt (ITFixed IT32))) = True
622 matchableTy (AType (ATInt (ITFixed IT64))) = True
624 matchableTy _ = False
626irAlt vs tm (SucCase n rhs) = do
627 rhs' <- irSC vs rhs
628 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))
629 [tm,
630 LConst (BI 1)]) rhs')
632irAlt vs _ (ConstCase c rhs)
633 = ifail $ "Can't match on (" ++ show c ++ ")"
635irAlt vs _ (DefaultCase rhs)
636 = LDefaultCase <$> irSC vs rhs