git.iko.soy/Idris-dev
on ee11033 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)
50import Paths_idris
52compile :: Codegen -> FilePath -> Term -> Idris ()
53compile codegen f tm
54 = do checkMVs -- check for undefined metavariables
55 checkTotality -- refuse to compile if there are totality problems
56 reachableNames <- performUsageAnalysis
57 maindef <- irMain tm
58 iLOG $ "MAIN: " ++ show maindef
59 objs <- getObjectFiles codegen
60 libs <- getLibs codegen
61 flags <- getFlags codegen
62 hdrs <- getHdrs codegen
63 impdirs <- allImportDirs
64 defsIn <- mkDecls tm reachableNames
65 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]
66 -- iputStrLn $ showSep "\n" (map show defs)
67 let (nexttag, tagged) = addTags 65536 (liftAll defs)
68 let ctxtIn = addAlist tagged emptyContext
69 iLOG "Defunctionalising"
70 let defuns_in = defunctionalise nexttag ctxtIn
71 logLvl 5 $ show defuns_in
72 iLOG "Inlining"
73 let defuns = inline defuns_in
74 logLvl 5 $ show defuns
75 iLOG "Resolving variables for CG"
76 -- iputStrLn $ showSep "\n" (map show (toAlist defuns))
77 let checked = checkDefs defuns (toAlist defuns)
78 outty <- outputTy
79 dumpCases <- getDumpCases
80 dumpDefun <- getDumpDefun
81 case dumpCases of
82 Nothing -> return ()
83 Just f -> runIO $ writeFile f (showCaseTrees defs)
84 case dumpDefun of
85 Nothing -> return ()
86 Just f -> runIO $ writeFile f (dumpDefuns defuns)
87 triple <- Idris.AbsSyntax.targetTriple
88 cpu <- Idris.AbsSyntax.targetCPU
89 optimise <- optLevel
90 iLOG "Building output"
92 case checked of
93 OK c -> do let cginfo = CodegenInfo f outty triple cpu optimise
94 hdrs impdirs objs libs flags
95 NONE c (toAlist defuns)
96 tagged
97 runIO $ case codegen of
98 ViaC -> codegenC cginfo
99 ViaJava -> codegenJava cginfo
100 ViaJavaScript -> codegenJavaScript cginfo
101 ViaNode -> codegenNode cginfo
102 ViaLLVM -> codegenLLVM cginfo
103 Bytecode -> dumpBC c f
104 Error e -> ierror e
105 where checkMVs = do i <- getIState
106 case map fst (idris_metavars i) \\ primDefs of
107 [] -> return ()
108 ms -> ifail $ "There are undefined metavariables: " ++ show ms
109 checkTotality = do i <- getIState
110 case idris_totcheckfail i of
111 [] -> return ()
112 ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n " ++ msg
113 inDir d h = do let f = d </> h
114 ex <- doesFileExist f
115 if ex then return f else return h
117irMain :: TT Name -> Idris LDecl
118irMain tm = do
119 i <- irTerm M.empty [] tm
120 return $ LFun [] (sMN 0 "runMain") [] (LForce i)
122mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]
123mkDecls t used
124 = do i <- getIState
125 let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
126 decls <- mapM build ds
127 return decls
129showCaseTrees :: [(Name, LDecl)] -> String
130showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)
131 where
132 showCT (n, LFun _ f args lexp)
133 = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"
134 ++ show lexp
135 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a
137 defnRank :: (Name, LDecl) -> String
138 defnRank (n, LFun _ _ _ _) = "1" ++ nameRank n
139 defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n
141 nameRank :: Name -> String
142 nameRank (UN s) = "1" ++ show s
143 nameRank (MN i s) = "2" ++ show s ++ show i
144 nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n
145 nameRank (SN sn) = "4" ++ snRank sn
146 nameRank n = "5" ++ show n
148 snRank :: SpecialName -> String
149 snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i
150 snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args
151 snRank (ParentN n s) = "3" ++ nameRank n ++ show s
152 snRank (MethodN n) = "4" ++ nameRank n
153 snRank (CaseN n) = "5" ++ nameRank n
154 snRank (ElimN n) = "6" ++ nameRank n
155 snRank (InstanceCtorN n) = "7" ++ nameRank n
157isCon (TyDecl _ _) = True
158isCon _ = False
160build :: (Name, Def) -> Idris (Name, LDecl)
161build (n, d)
162 = do i <- getIState
163 case lookup n (idris_scprims i) of
164 Just (ar, op) ->
165 let args = map (\x -> sMN x "op") [0..] in
166 return (n, (LFun [] n (take ar args)
167 (LOp op (map (LV . Glob) (take ar args)))))
168 _ -> do def <- mkLDecl n d
169 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
170 return (n, def)
172declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x
173declArgs args inl n x = LFun (if inl then [Inline] else []) n args x
175mkLDecl n (Function tm _)
176 = declArgs [] True n <$> irTerm M.empty [] tm
178mkLDecl n (CaseOp ci _ _ _ pats cd)
179 = declArgs [] (case_inlinable ci) n <$> irTree args sc
180 where
181 (args, sc) = cases_runtime cd
183mkLDecl n (TyDecl (DCon tag arity) _) =
184 LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)
186mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a
187mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run
189data VarInfo = VI
190 { viMethod :: Maybe Name
191 }
192 deriving Show
194type Vars = M.Map Name VarInfo
196irTerm :: Vars -> [Name] -> Term -> Idris LExp
197irTerm vs env tm@(App f a) = case unApply tm of
198 (P _ (UN m) _, args)
199 | m == txt "mkForeignPrim"
200 -> doForeign vs env args
202 (P _ (UN u) _, [_, arg])
203 | u == txt "unsafePerformPrimIO"
204 -> irTerm vs env arg
206 -- TMP HACK - until we get inlining.
207 (P _ (UN r) _, [_, _, _, _, _, arg])
208 | r == txt "replace"
209 -> irTerm vs env arg
211 -- Laziness, the old way
212 (P _ (UN l) _, [_, arg])
213 | l == txt "lazy"
214 -> error "lazy has crept in somehow"
216 (P _ (UN l) _, [_, arg])
217 | l == txt "force"
218 -> LForce <$> irTerm vs env arg
220 -- Laziness, the new way
221 (P _ (UN l) _, [_, _, arg])
222 | l == txt "Delay"
223 -> LLazyExp <$> irTerm vs env arg
225 (P _ (UN l) _, [_, _, arg])
226 | l == txt "Force"
227 -> LForce <$> irTerm vs env arg
229 (P _ (UN a) _, [_, _, _, arg])
230 | a == txt "assert_smaller"
231 -> irTerm vs env arg
233 (P _ (UN a) _, [_, arg])
234 | a == txt "assert_total"
235 -> irTerm vs env arg
237 (P _ (UN p) _, [_, arg])
238 | p == txt "par"
239 -> do arg' <- irTerm vs env arg
240 return $ LOp LPar [LLazyExp arg']
242 (P _ (UN pf) _, [arg])
243 | pf == txt "prim_fork"
244 -> do arg' <- irTerm vs env arg
245 return $ LOp LFork [LLazyExp arg']
247 (P _ (UN m) _, [_,size,t])
248 | m == txt "malloc"
249 -> irTerm vs env t
251 (P _ (UN tm) _, [_,t])
252 | tm == txt "trace_malloc"
253 -> irTerm vs env t -- TODO
255 -- This case is here until we get more general inlining. It's just
256 -- a really common case, and the laziness hurts...
257 (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),
258 (App (App (App (P _ (UN d') _) _) _) e)])
259 | be == txt "boolElim"
260 , d == txt "Delay"
261 , d' == txt "Delay"
262 -> do
263 x' <- irTerm vs env x
264 t' <- irTerm vs env t
265 e' <- irTerm vs env e
266 return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'
267 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'
268 ])
270 -- data constructor
271 (P (DCon t arity) n _, args) -> do
272 detag <- fgetState (opt_detaggable . ist_optimisation n)
273 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
275 let isNewtype = length used == 1 && detag
276 let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]
278 -- The following code removes fields from data constructors
279 -- and performs the newtype optimisation.
280 --
281 -- The general rule here is:
282 -- Everything we get as input is not touched by erasure,
283 -- so it conforms to the official arities and types
284 -- and we can reason about it like it's plain TT.
285 --
286 -- It's only the data that leaves this point that's erased
287 -- and possibly no longer typed as the original TT version.
288 --
289 -- Especially, underapplied constructors must yield functions
290 -- even if all the remaining arguments are erased
291 -- (the resulting function *will* be applied, to NULLs).
292 --
293 -- This will probably need rethinking when we get erasure from functions.
295 -- "padLams" will wrap our term in LLam-bdas and give us
296 -- the "list of future unerased args" coming from these lambdas.
297 --
298 -- We can do whatever we like with the list of unerased args,
299 -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.
300 let padLams = padLambdas used (length args) arity
302 case compare arity (length args) of
304 -- overapplied
305 GT -> ifail ("overapplied data constructor: " ++ show tm)
307 -- exactly saturated
308 EQ | isNewtype
309 -> irTerm vs env (head argsPruned)
311 | otherwise -- not newtype, plain data ctor
312 -> buildApp (LV $ Glob n) argsPruned
314 -- not saturated, underapplied
315 LT | isNewtype -- newtype
316 , length argsPruned == 1 -- and we already have the value
317 -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args
318 <$> irTerm vs env (head argsPruned)
320 | isNewtype -- newtype but the value is not among args yet
321 -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]
323 -- not a newtype, just apply to a constructor
324 | otherwise
325 -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned
327 -- type constructor
328 (P (TCon t a) n _, args) -> return LNothing
330 -- a name applied to arguments
331 (P _ n _, args) -> do
332 ist <- getIState
333 case lookup n (idris_scprims ist) of
334 -- if it's a primitive that is already saturated,
335 -- compile to the corresponding op here already to save work
336 Just (arity, op) | length args == arity
337 -> LOp op <$> mapM (irTerm vs env) args
339 -- otherwise, just apply the name
340 _ -> applyName n ist args
342 -- turn de bruijn vars into regular named references and try again
343 (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args
345 (f, args)
346 -> LApp False
347 <$> irTerm vs env f
348 <*> mapM (irTerm vs env) args
350 where
351 buildApp :: LExp -> [Term] -> Idris LExp
352 buildApp e [] = return e
353 buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs
355 applyToNames :: LExp -> [Name] -> LExp
356 applyToNames tm [] = tm
357 applyToNames tm ns = LApp False tm $ map (LV . Glob) ns
359 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
360 padLambdas used startIdx endSIdx mkTerm
361 = LLam allNames $ mkTerm nonerasedNames
362 where
363 allNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]
364 nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]
366 applyName :: Name -> IState -> [Term] -> Idris LExp
367 applyName n ist args =
368 LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)
369 where
370 erase (i, x)
371 | i >= arity || i `elem` used = x
372 | otherwise = Erased
374 arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of
375 Just (CaseOp ci ty tys def tot cdefs) -> length tys
376 Just (TyDecl (DCon tag ar) _) -> ar
377 Just (TyDecl Ref ty) -> length $ getArgTys ty
378 Just (Operator ty ar op) -> ar
379 Just def -> error $ "unknown arity: " ++ show (n, def)
380 Nothing -> 0 -- no definition, probably local name => can't erase anything
382 -- name for purposes of usage info lookup
383 uName
384 | Just n' <- viMethod =<< M.lookup n vs = n'
385 | otherwise = n
387 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
388 fst4 (x,_,_,_) = x
390irTerm vs env (P _ n _) = return $ LV (Glob n)
391irTerm vs env (V i)
392 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
393 | otherwise = ifail $ "bad de bruijn index: " ++ show i
395irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc
396 where
397 n' = uniqueName n env
399irTerm vs env (Bind n (Let _ v) sc)
400 = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc
402irTerm vs env (Bind _ _ _) = return $ LNothing
404irTerm vs env (Proj t (-1)) = do
405 t' <- irTerm vs env t
406 return $ LOp (LMinus (ATInt ITBig))
407 [t', LConst (BI 1)]
409irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i
410irTerm vs env (Constant c) = return $ LConst c
411irTerm vs env (TType _) = return $ LNothing
412irTerm vs env Erased = return $ LNothing
413irTerm vs env Impossible = return $ LNothing
415doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp
416doForeign vs env (_ : fgn : args)
417 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
418 = case getFTypes fgnArgTys of
419 Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)
420 Just tys -> do
421 args' <- mapM (irTerm vs env) (init args)
422 return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')
424 | otherwise = ifail "Badly formed foreign function call"
425 where
426 getFTypes :: TT Name -> Maybe [FType]
427 getFTypes tm = case unApply tm of
428 -- nil : {a : Type} -> List a
429 (nil, [_]) -> Just []
430 -- cons : {a : Type} -> a -> List a -> List a
431 (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs
432 _ -> Nothing
434 mkIty' (P _ (UN ty) _) = mkIty (str ty)
435 mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))
436 | fi == txt "FIntT"
437 = mkIntIty (str intTy)
439 mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))
440 | ff == txt "FFunction"
441 , fa == txt "FAny"
442 , io == txt "IO"
443 = FFunctionIO
445 mkIty' (App (App (P _ (UN ff) _) _) _)
446 | ff == txt "FFunction"
447 = FFunction
449 mkIty' _ = FAny
451 -- would be better if these FInt types were evaluated at compile time
452 -- TODO: add %eval directive for such things
454 mkIty "FFloat" = FArith ATFloat
455 mkIty "FInt" = mkIntIty "ITNative"
456 mkIty "FChar" = mkIntIty "ITChar"
457 mkIty "FByte" = mkIntIty "IT8"
458 mkIty "FShort" = mkIntIty "IT16"
459 mkIty "FLong" = mkIntIty "IT64"
460 mkIty "FBits8" = mkIntIty "IT8"
461 mkIty "FBits16" = mkIntIty "IT16"
462 mkIty "FBits32" = mkIntIty "IT32"
463 mkIty "FBits64" = mkIntIty "IT64"
464 mkIty "FString" = FString
465 mkIty "FPtr" = FPtr
466 mkIty "FManagedPtr" = FManagedPtr
467 mkIty "FUnit" = FUnit
468 mkIty "FFunction" = FFunction
469 mkIty "FFunctionIO" = FFunctionIO
470 mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16))
471 mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8))
472 mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4))
473 mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2))
474 mkIty x = error $ "Unknown type " ++ x
476 mkIntIty "ITNative" = FArith (ATInt ITNative)
477 mkIntIty "ITChar" = FArith (ATInt ITChar)
478 mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))
479 mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))
480 mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))
481 mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))
483irTree :: [Name] -> SC -> Idris LExp
484irTree args tree = do
485 logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
486 LLam args <$> irSC M.empty tree
488irSC :: Vars -> SC -> Idris LExp
489irSC vs (STerm t) = irTerm vs [] t
490irSC vs (UnmatchedCase str) = return $ LError str
491irSC vs (ProjCase tm alts) = do
492 tm' <- irTerm vs [] tm
493 alts' <- mapM (irAlt vs tm') alts
494 return $ LCase tm' alts'
496-- Transform matching on Delay to applications of Force.
497irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])
498 | delay == txt "Delay"
499 = irSC vs $ mkForce n 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