git.iko.soy/Idris-dev
on 9040aba help sign in
Idris-dev/src/IRTS/Compiler.hs
634 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
489irSC vs (ProjCase tm alts) = do
490 tm' <- irTerm vs [] tm
491 alts' <- mapM (irAlt vs tm') alts
492 return $ LCase tm' alts'
494-- Transform matching on Delay to applications of Force.
495irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])
496 | delay == txt "Delay"
497 = irSC vs $ mkForce n n' sc
499-- There are two transformations in this case:
500--
501-- 1. Newtype-case elimination:
502-- case {e0} of
503-- wrap({e1}) -> P({e1}) ==> P({e0})
504--
505-- This is important because newtyped constructors are compiled away entirely
506-- and we need to do that everywhere.
507--
508-- 2. Unused-case elimination (only valid for singleton branches):
509-- case {e0} of ==> P
510-- C(x,y) -> P[... x,y not used ...]
511--
512-- This is important for runtime because sometimes we case on irrelevant data:
513--
514-- In the example above, {e0} will most probably have been erased
515-- so this vain projection would make the resulting program segfault
516-- because the code generator still emits a PROJECT(...) G-machine instruction.
517--
518-- Hence, we check whether the variables are used at all
519-- and erase the casesplit if they are not.
520--
521irSC vs (Case n [alt]) = do
522 replacement <- case alt of
523 ConCase cn a ns sc -> do
524 detag <- fgetState (opt_detaggable . ist_optimisation cn)
525 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)
526 if detag && length used == 1
527 then return . Just $ substSC (ns !! head used) n sc
528 else return Nothing
529 _ -> return Nothing
531 case replacement of
532 Just sc -> irSC vs sc
533 _ -> do
534 alt' <- irAlt vs (LV (Glob n)) alt
535 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
536 [] -> subexpr alt' -- strip the unused top-most case
537 _ -> LCase (LV (Glob n)) [alt']
538 where
539 namesBoundIn :: LAlt -> [Name]
540 namesBoundIn (LConCase cn i ns sc) = ns
541 namesBoundIn (LConstCase c sc) = []
542 namesBoundIn (LDefaultCase sc) = []
544 subexpr :: LAlt -> LExp
545 subexpr (LConCase _ _ _ e) = e
546 subexpr (LConstCase _ e) = e
547 subexpr (LDefaultCase e) = e
549-- FIXME: When we have a non-singleton case-tree of the form
550--
551-- case {e0} of
552-- C(x) => ...
553-- ... => ...
554--
555-- and C is detaggable (the only constructor of the family), we can be sure
556-- that the first branch will be always taken -- so we add special handling
557-- to remove the dead default branch.
558--
559-- If we don't do so and C is newtype-optimisable, we will miss this newtype
560-- transformation and the resulting code will probably segfault.
561--
562-- This work-around is not entirely optimal; the best approach would be
563-- to ensure that such case trees don't arise in the first place.
564--
565irSC vs (Case n alts@[ConCase cn a ns sc, DefaultCase sc']) = do
566 detag <- fgetState (opt_detaggable . ist_optimisation cn)
567 if detag
568 then irSC vs (Case n [ConCase cn a ns sc])
569 else LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
571irSC vs sc@(Case n alts) = do
572 -- check that neither alternative needs the newtype optimisation,
573 -- see comment above
574 goneWrong <- or <$> mapM isDetaggable alts
575 when goneWrong
576 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
578 -- everything okay
579 LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
580 where
581 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
582 isDetaggable _ = return False
584irSC vs ImpossibleCase = return LNothing
586irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt
588-- this leaves out all unused arguments of the constructor
589irAlt vs _ (ConCase n t args sc) = do
590 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
591 let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]
592 LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc
593 where
594 methodVars = case n of
595 SN (InstanceCtorN className)
596 -> M.fromList [(v, VI
597 { viMethod = Just $ mkFieldName n i
598 }) | (v,i) <- zip args [0..]]
599 _
600 -> M.empty -- not an instance constructor
602irAlt vs _ (ConstCase x rhs)
603 | matchable x = LConstCase x <$> irSC vs rhs
604 | matchableTy x = LDefaultCase <$> irSC vs rhs
605 where
606 matchable (I _) = True
607 matchable (BI _) = True
608 matchable (Ch _) = True
609 matchable (Str _) = True
610 matchable _ = False
612 matchableTy (AType (ATInt ITNative)) = True
613 matchableTy (AType (ATInt ITBig)) = True
614 matchableTy (AType (ATInt ITChar)) = True
615 matchableTy StrType = True
617 matchableTy (AType (ATInt (ITFixed IT8))) = True
618 matchableTy (AType (ATInt (ITFixed IT16))) = True
619 matchableTy (AType (ATInt (ITFixed IT32))) = True
620 matchableTy (AType (ATInt (ITFixed IT64))) = True
622 matchableTy _ = False
624irAlt vs tm (SucCase n rhs) = do
625 rhs' <- irSC vs rhs
626 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))
627 [tm,
628 LConst (BI 1)]) rhs')
630irAlt vs _ (ConstCase c rhs)
631 = ifail $ "Can't match on (" ++ show c ++ ")"
633irAlt vs _ (DefaultCase rhs)
634 = LDefaultCase <$> irSC vs rhs