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