-
Notifications
You must be signed in to change notification settings - Fork 47
Expand file tree
/
Copy pathTrans.hs
More file actions
3269 lines (2926 loc) · 140 KB
/
Trans.hs
File metadata and controls
3269 lines (2926 loc) · 140 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module Mir.Trans(transCollection,transStatics,RustModule(..)
, readMirRef
, writeMirRef
, subindexRef
, evalBinOp
, evalOperand
, vectorCopy, aggregateCopy_constLen
, ptrCopy, copyNonOverlapping
, isNonOverlapping
, evalRval
, callExp
, callHandle
, doVirtCall
, derefExp, readPlace, addrOfPlace
, transmuteExp
, extendUnsignedBV
) where
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans.Class
import Control.Lens hiding (op,(|>))
import qualified Control.Lens.Extras as Lens (is)
import Data.Foldable
import Data.Bits (shift, shiftL)
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.STRef
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Traversable as Trav
import Data.String (fromString)
import Numeric
import Numeric.Natural()
import Prettyprinter (Pretty(..))
import qualified Prettyprinter as PP
import qualified Lang.Crucible.CFG.Generator as G
import qualified Lang.Crucible.FunctionHandle as FH
import qualified What4.ProgramLoc as PL
import qualified What4.FunctionName as FN
import qualified What4.Utils.StringLiteral as W4
import qualified Lang.Crucible.CFG.Reg as R
import qualified Lang.Crucible.CFG.SSAConversion as SSA
import qualified Lang.Crucible.CFG.Expr as E
import qualified Lang.Crucible.CFG.Core as Core
import qualified Lang.Crucible.Syntax as S
import qualified Lang.Crucible.Types as C
import Lang.Crucible.Panic
import qualified Data.Parameterized.Context as Ctx
import Data.Parameterized.Classes
import Data.Parameterized.NatRepr
import Data.Parameterized.Some
import Data.Parameterized.TraversableFC
import Data.Parameterized.Nonce (newSTNonceGenerator)
import Mir.Mir
import qualified Mir.Mir as M
import qualified Mir.DefId as M
import Mir.Intrinsics
import Mir.Generator
import Mir.GenericOps
import Mir.TransTy
import Mir.PP (fmt, fmtDoc)
import Debug.Trace
parsePosition :: Text.Text -> PL.Position
parsePosition posText =
case Text.split (== ':') posText of
[fname',line,col]
| (l,[]):_ <- readDec (Text.unpack line)
, (c,[]):_ <- readDec (Text.unpack col)
-> PL.SourcePos fname' l c
_ -> PL.OtherPos posText
setPosition :: Text.Text -> MirGenerator h s ret ()
setPosition = G.setPosition . parsePosition
--------------------------------------------------------------------------------------
-- ** Expressions
-- Expressions: variables and constants
--
transConstVal :: HasCallStack => M.Ty -> Some C.TypeRepr -> M.ConstVal -> MirGenerator h s ret (MirExp s)
-- Custom types
transConstVal (CTyBv _) (Some (C.BVRepr w)) (M.ConstStruct [M.ConstInt i, M.ConstStruct []]) = do
val <- case M.fromIntegerLit i of
0 -> return 0 -- Bv::ZERO
1 -> return 1 -- Bv::ONE
2 -> return $ (1 `shift` fromIntegral (intValue w)) - 1 -- Bv::MAX
i' -> mirFail $ "unknown bitvector constant " ++ show i'
return $ MirExp (C.BVRepr w) (S.app $ eBVLit w val)
transConstVal CTyMethodSpec _ _ = do
mirFail "transConstVal: can't construct MethodSpec without an override"
transConstVal CTyMethodSpecBuilder _ _ = do
mirFail "transConstVal: can't construct MethodSpecBuilder without an override"
transConstVal _ty (Some (C.BVRepr w)) (M.ConstInt i) =
return $ MirExp (C.BVRepr w) (S.app $ eBVLit w (fromInteger (M.fromIntegerLit i)))
transConstVal _ty (Some (C.BoolRepr)) (M.ConstBool b) = return $ MirExp (C.BoolRepr) (S.litExpr b)
transConstVal _ty (Some (UsizeRepr)) (M.ConstInt i) =
do let n = fromInteger (M.fromIntegerLit i)
return $ MirExp UsizeRepr (S.app $ usizeLit n)
transConstVal _ty (Some (IsizeRepr)) (ConstInt i) =
return $ MirExp IsizeRepr (S.app $ isizeLit (fromIntegerLit i))
--
-- This code handles slice references, both for ordinary array slices
-- and string slices. (These differ from ordinary references in having
-- a length.) It needs to look up the definition ID, and then:
-- * extract the type from the global variable it finds
-- (note that it'll be a MirVectorRepr that it needs to unwrap)
-- * construct a reference to the global variable
-- (with globalMirRef rather than constMirRef, that's the point of
-- all this)
-- * apply subindexRef as above
-- * cons up the length
-- * call mkStruct
-- * cons up the final MirExp
--
-- staticSlicePlace does the first four of these actions; addrOfPlace
-- does the last two.
--
transConstVal (M.TyRef (M.TySlice ty) _) (Some MirSliceRepr) (M.ConstSliceRef defid len) = do
Some tpr <- tyToReprM ty
place <- staticSlicePlace len (Some tpr) defid
addrOfPlace place
transConstVal (M.TyRef M.TyStr _) (Some MirSliceRepr) (M.ConstSliceRef defid len) = do
let tpr = C.BVRepr $ knownNat @8
place <- staticSlicePlace len (Some tpr) defid
addrOfPlace place
transConstVal _ty (Some MirAggregateRepr) (M.ConstStrBody bs) = do
let bytes = map (\b -> R.App (eBVLit (knownNat @8) (toInteger b))) (BS.unpack bs)
ag <- mirAggregate_uninit_constSize (fromIntegral $ length bytes)
-- TODO: hardcoded size=1
ag' <- foldM
(\ag' (i, b) -> mirAggregate_set i 1 knownRepr b ag')
ag (zip [0..] bytes)
return $ MirExp MirAggregateRepr ag'
transConstVal (M.TyArray ty _sz) (Some MirAggregateRepr) (M.ConstArray arr) = do
Some tpr <- tyToReprM ty
arr' <- Trav.for arr $ \e -> do
MirExp tpr' e' <- transConstVal ty (Some tpr) e
Refl <- testEqualityOrFail tpr tpr' $
"transConstVal (ConstArray): returned wrong type: expected " ++
show tpr ++ ", got " ++ show tpr'
pure e'
ag <- mirAggregate_uninit_constSize (fromIntegral $ length arr')
-- TODO: hardcoded size=1
ag' <- foldM
(\ag' (i, x) -> mirAggregate_set i 1 tpr x ag')
ag (zip [0..] arr')
return $ MirExp MirAggregateRepr ag'
transConstVal _ty (Some (C.BVRepr w)) (M.ConstChar c) =
do let i = toInteger (Char.ord c)
return $ MirExp (C.BVRepr w) (S.app $ eBVLit w i)
transConstVal _ty (Some C.UnitRepr) (M.ConstFunction _did) =
return $ MirExp C.UnitRepr $ S.app E.EmptyApp
transConstVal _ty (Some C.UnitRepr) (M.ConstTuple []) =
return $ MirExp C.UnitRepr $ S.app E.EmptyApp
transConstVal (M.TyTuple tys) (Some MirAggregateRepr) (M.ConstTuple vals) =
transConstTuple tys vals
transConstVal (M.TyClosure upvar_tys) (Some MirAggregateRepr) (M.ConstClosure upvar_vals) =
transConstTuple upvar_tys upvar_vals
transConstVal _ty (Some (C.RealValRepr)) (M.ConstFloat (M.FloatLit _ str)) =
case reads str of
(d , _):_ -> let rat = toRational (d :: Double) in
return (MirExp C.RealValRepr (S.app $ E.RationalLit rat))
[] -> mirFail $ "cannot parse float constant: " ++ show str
transConstVal _ty _ (ConstInitializer funid) =
callExp funid []
transConstVal _ty _ (ConstStaticRef did) =
staticPlace did >>= addrOfPlace
transConstVal ty _ ConstZST = initialValue ty >>= \case
Just x -> return x
Nothing -> mirFail $
"failed to evaluate ZST constant of type " ++ show ty ++ " (initialValue failed)"
transConstVal _ty (Some MirReferenceRepr) (ConstRawPtr i) =
MirExp MirReferenceRepr <$> integerToMirRef (R.App $ usizeLit i)
transConstVal ty@(M.TyAdt aname _ _) tpr (ConstStruct fields) = do
adt <- findAdt aname
col <- use $ cs . collection
case findReprTransparentField col adt of
Just idx ->
transTransparentVal ty tpr adt fields idx
Nothing -> do
let fieldDefs = adt ^. adtvariants . ix 0 . vfields
let fieldTys = map (\f -> f ^. fty) fieldDefs
exps <- zipWithM (\val ty' -> tyToReprM ty' >>= \rpr -> transConstVal ty' rpr val) fields fieldTys
buildStruct adt exps
transConstVal ty@(M.TyAdt aname _ _) tpr (ConstEnum variant fields) = do
adt <- findAdt aname
col <- use $ cs . collection
case findReprTransparentField col adt of
Just idx ->
transTransparentVal ty tpr adt fields idx
Nothing -> do
let fieldDefs = adt ^. adtvariants . ix variant . vfields
let fieldTys = map (\f -> f ^. fty) fieldDefs
exps <- zipWithM (\val ty' -> tyToReprM ty' >>= \rpr -> transConstVal ty' rpr val) fields fieldTys
buildEnum adt variant exps
transConstVal ty (Some MirReferenceRepr) cv = do
let pointeeTy = M.typeOfProj M.Deref ty
Some tpr <- tyToReprM pointeeTy
MirExp tpr' val <- transConstVal pointeeTy (Some tpr) cv
Refl <- testEqualityOrFail tpr tpr' $
"transConstVal returned wrong type: expected " ++ show tpr ++ ", got " ++ show tpr'
ref <- constMirRef tpr val
return $ MirExp MirReferenceRepr ref
transConstVal _ty (Some tpr@(C.FunctionHandleRepr argTys retTy)) (ConstFnPtr did) = do
mbHndl <- resolveFn did
case mbHndl of
Just (MirHandle _ _ hndl) -> do
Refl <- testEqualityOrFail argTys (FH.handleArgTypes hndl) $ unlines
[ "transConstVal (ConstFnPtr): argument types mismatch"
, "expected: " ++ show argTys
, "actual: " ++ show (FH.handleArgTypes hndl)
, "def id: " ++ show did
]
Refl <- testEqualityOrFail retTy (FH.handleReturnType hndl) $ unlines
[ "transConstVal (ConstFnPtr): return type mismatch"
, "expected: " ++ show retTy
, "actual: " ++ show (FH.handleReturnType hndl)
, "def id: " ++ show did
]
return $ MirExp tpr $ R.App $ E.HandleLit hndl
Nothing -> mirFail $
"transConstVal (ConstFnPtr): Couldn't resolve function " ++ show did
transConstVal ty tp cv = mirFail $
"fail or unimp constant: " ++ show ty ++ " (" ++ show tp ++ ") " ++ show cv
-- Translate a constant (non-empty) tuple or constant closure value.
transConstTuple :: [M.Ty] -> [ConstVal] -> MirGenerator h s ret (MirExp s)
transConstTuple tys vals = do
exps <- forM (zip tys vals) $ \(ty, val) -> do
Some tpr <- tyToReprM ty
transConstVal ty (Some tpr) val
buildTupleMaybeM tys (map Just exps)
-- Translate a struct or enum marked with repr(transparent).
transTransparentVal ::
M.Ty {- The transparent struct or enum type (only used for error messages) -} ->
Some C.TypeRepr {- The Crucible representation of the transparent struct or
enum type. -} ->
Adt {- The transparent struct or enum's Adt description. -} ->
[ConstVal] {- The field values of the transparent struct or enum variant.
Really, it should only be a single field value, but we must
check that this is actually the case. -} ->
Int {- The index of the underlying field in the variant. -} ->
MirGenerator h s ret (MirExp s)
transTransparentVal ty tpr adt fields idx = do
ty' <- case adt ^? adtvariants . ix 0 . vfields . ix idx . fty of
Just x -> return x
Nothing -> mirFail $ "repr(transparent) field index " ++ show idx ++
" out of range for " ++ show (pretty ty)
constant <- case fields ^? ix idx of
Just x -> return x
Nothing -> mirFail $ "repr(transparent) field index " ++ show idx ++
" out of range for " ++ show (pretty ty') ++ " initializer"
transConstVal ty' tpr constant
typedVarInfo :: HasCallStack => Text -> C.TypeRepr tp -> MirGenerator h s ret (VarInfo s tp)
typedVarInfo name tpr = do
optV <- use $ varMap . at name
case optV of
Nothing -> mirFail $
"variable " ++ show name ++ " not found"
Just (Some vi) -> do
let tpr' = varInfoRepr vi
Refl <- testEqualityOrFail tpr tpr' $
"expected var " ++ show name ++ " to have type " ++ show tpr
++ ", but it has type " ++ show tpr' ++ " instead"
return vi
readVar :: C.TypeRepr tp -> VarInfo s tp -> MirGenerator h s ret (R.Expr MIR s tp)
readVar tpr vi = do
case vi of
VarRegister reg -> G.readReg reg
VarReference _ reg -> G.readReg reg >>= readMirRef tpr
VarAtom a -> return $ R.AtomExpr a
varExp :: HasCallStack => M.Var -> MirGenerator h s ret (MirExp s)
varExp (M.Var vname' _ vty _) = do
Some tpr <- tyToReprM vty
vi <- typedVarInfo vname' tpr
x <- readVar tpr vi
return $ MirExp tpr x
varPlace :: HasCallStack => M.Var -> MirGenerator h s ret (MirPlace s)
varPlace (M.Var vname' _ vty _) = do
Some tpr <- tyToReprM vty
vi <- typedVarInfo vname' tpr
r <- case vi of
VarReference _ reg -> G.readReg reg
-- TODO: these cases won't be needed once immutable ref support is done
-- - make them report an error instead
VarRegister reg -> do
x <- G.readReg reg
r <- constMirRef tpr x
return r
VarAtom a -> do
r <- constMirRef tpr $ R.AtomExpr a
return r
return $ MirPlace tpr r NoMeta
staticPlace :: HasCallStack => M.DefId -> MirGenerator h s ret (MirPlace s)
staticPlace did = do
sm <- use $ cs.staticMap
case Map.lookup did sm of
Just (StaticVar gv) ->
MirPlace (G.globalType gv) <$> globalMirRef gv <*> pure NoMeta
Nothing -> mirFail $ "cannot find static variable " ++ fmt did
-- variant of staticPlace for slices
-- tpr is the element type; len is the length
staticSlicePlace ::
HasCallStack =>
Int ->
Some C.TypeRepr ->
M.DefId ->
MirGenerator h s ret (MirPlace s)
staticSlicePlace len (Some tpr) did = do
sm <- use $ cs.staticMap
case Map.lookup did sm of
Just (StaticVar gv) -> do
let tpr_found = G.globalType gv
-- TODO: why is `() <- ...` needed here?
() <- case tpr_found of
MirAggregateRepr -> return ()
_ -> mirFail $
"staticSlicePlace: wrong type: expected vector, found " ++ show tpr_found
ref <- globalMirRef gv
ref' <- subindexRef tpr ref (R.App $ usizeLit 0)
let len' = R.App $ usizeLit $ fromIntegral len
return $ MirPlace tpr ref' (SliceMeta len')
Nothing -> mirFail $ "cannot find static variable " ++ fmt did
-- NOTE: The return var in the MIR output is always "_0"
getReturnExp :: HasCallStack => C.TypeRepr ret -> MirGenerator h s ret (R.Expr MIR s ret)
getReturnExp tpr = do
vi <- typedVarInfo "_0" tpr
readVar tpr vi
-- ** Expressions: Operations and Aggregates
evalOperand :: HasCallStack => M.Operand -> MirGenerator h s ret (MirExp s)
evalOperand (M.Copy lv) = evalPlace lv >>= readPlace
evalOperand (M.Move lv) = evalPlace lv >>= readPlace
evalOperand (M.OpConstant (M.Constant conty constval)) = do
Some tpr <- tyToReprM conty
transConstVal conty (Some tpr) constval
evalOperand (M.Temp rv) = evalRval rv
-- | Dereference a `MirExp` (which must be `MirReferenceRepr` pointing to a
-- sized type), producing a `MirPlace`.
derefExp :: HasCallStack => M.Ty -> MirExp s -> MirGenerator h s ret (MirPlace s)
derefExp pointeeTy (MirExp MirReferenceRepr e) = do
Some tpr <- tyToReprM pointeeTy
return $ MirPlace tpr e NoMeta
derefExp _pointeeTy (MirExp tpr _) = mirFail $ "don't know how to deref " ++ show tpr
readPlace :: HasCallStack => MirPlace s -> MirGenerator h s ret (MirExp s)
readPlace (MirPlace tpr r NoMeta) = MirExp tpr <$> readMirRef tpr r
readPlace (MirPlace tpr _ meta) =
mirFail $ "don't know how to read from place with metadata " ++ show meta
++ " (type " ++ show tpr ++ ")"
addrOfPlace :: HasCallStack => MirPlace s -> MirGenerator h s ret (MirExp s)
addrOfPlace (MirPlace _tpr r NoMeta) = return $ MirExp MirReferenceRepr r
addrOfPlace (MirPlace _tpr r (SliceMeta len)) =
return $ MirExp MirSliceRepr $ mkSlice r len
addrOfPlace (MirPlace _tpr r (DynMeta vtable)) =
return $ MirExp DynRefRepr $
R.App $ E.MkStruct DynRefCtx $
Ctx.Empty Ctx.:> r Ctx.:> vtable
-- Given two bitvectors, extend the length of the shorter one so that they
-- have the same length
-- Use the sign of the first bitvector to determine how to sign extend
extendToMax :: (1 <= n, 1 <= m) =>
NatRepr n -> G.Expr MIR s (C.BVType n) ->
NatRepr m -> G.Expr MIR s (C.BVType m) -> Maybe M.ArithType ->
(forall n'. (1 <= n') => NatRepr n' -> G.Expr MIR s (C.BVType n') -> G.Expr MIR s (C.BVType n') -> a) -> a
extendToMax n e1 m e2 (Just arith) k =
let extend :: (1 <= w, 1 <= r, w + 1 <= r) => (NatRepr r)
-> (NatRepr w)
-> (f (C.BVType w))
-> E.App MIR f (C.BVType r)
extend = case arith of
M.Signed -> E.BVSext
M.Unsigned -> E.BVZext
in case testEquality n m of
Just Refl -> k n e1 e2
Nothing -> case testLeq (incNat n) m of
Just LeqProof ->
k m (S.app $ extend m n e1) e2
Nothing -> case testLeq (incNat m) n of
Just LeqProof ->
k n e1 (S.app $ extend n m e2)
Nothing -> error "impossible case"
extendToMax n e1 m e2 Nothing k =
case testEquality n m of
Just Refl -> k n e1 e2
Nothing -> error "don't know the sign"
transBinOp :: M.BinOp -> M.Operand -> M.Operand -> MirGenerator h s ret (MirExp s)
transBinOp bop op1 op2 = do
me1 <- evalOperand op1
me2 <- evalOperand op2
let mat = M.arithType op1 `mplus` M.arithType op2
case bop of
Unchecked bop' -> do
(res, overflow) <- evalBinOp bop' mat me1 me2
G.assertExpr (S.notExpr overflow) $
S.litExpr $
"Binary operation (" <> Text.pack (show (pretty bop')) <>
") would overflow"
pure res
WithOverflow bop' -> do
(res, overflow) <- evalBinOp bop' mat me1 me2
buildTupleM [typeOf op1, TyBool] [res, MirExp C.BoolRepr overflow]
_ -> fst <$> evalBinOp bop mat me1 me2
-- Evaluate a binop, returning both the result and an overflow flag.
evalBinOp :: forall h s ret. M.BinOp -> Maybe M.ArithType -> MirExp s -> MirExp s ->
MirGenerator h s ret (MirExp s, R.Expr MIR s C.BoolType)
evalBinOp bop mat me1 me2 =
case (me1, me2) of
(MirExp ty1@(C.BVRepr na) e1a, MirExp ty2@C.NatRepr e2a) ->
case (bop, mat) of
(M.Shl, _) -> do
let e2bv = S.app (E.IntegerToBV na (S.app (E.NatToInteger e2a)))
return (MirExp (C.BVRepr na) (S.app $ E.BVShl na e1a e2bv),
shiftOverflowNat na e2a)
(M.Shr, Just M.Unsigned) -> do
let e2bv = S.app (E.IntegerToBV na (S.app (E.NatToInteger e2a)))
return (MirExp (C.BVRepr na) (S.app $ E.BVLshr na e1a e2bv),
shiftOverflowNat na e2a)
(M.Shr, Just M.Signed) -> do
let e2bv = S.app (E.IntegerToBV na (S.app (E.NatToInteger e2a)))
return (MirExp (C.BVRepr na) (S.app $ E.BVAshr na e1a e2bv),
shiftOverflowNat na e2a)
_ -> mirFail $ "No translation for binop: " ++ show bop ++ " with " ++ show ty1 ++ " and " ++ show ty2
(MirExp ty1@(C.BVRepr na) e1a, MirExp ty2@(C.BVRepr ma) e2a) ->
-- In all cases except shifts, the inputs should already have the
-- same width, and `extendToMax` is a no-op (except it provides the
-- proof that `na` and `ma` are equal). For shifts, the second input
-- (shift amount) can have any width, so we pad one side or the other
-- to make the widths match up.
extendToMax na e1a ma e2a (mat) $ \ n e1 e2 ->
case (bop, mat) of
(M.Add, _) -> do
let carry = case mat of
Just M.Unsigned -> E.BVCarry
Nothing -> E.BVCarry
Just M.Signed -> E.BVSCarry
return (MirExp (C.BVRepr n) (S.app $ E.BVAdd n e1 e2), S.app $ carry n e1 e2)
(M.Sub, _) -> do
let borrow = case mat of
Just M.Unsigned -> E.BVUlt
Nothing -> E.BVUlt
Just M.Signed -> E.BVSBorrow
return (MirExp (C.BVRepr n) (S.app $ E.BVSub n e1 e2), S.app $ borrow n e1 e2)
(M.Mul, Just M.Unsigned) ->
return (MirExp (C.BVRepr n) (S.app $ E.BVMul n e1 e2), umulOverflow n e1 e2)
(M.Mul, Just M.Signed) ->
return (MirExp (C.BVRepr n) (S.app $ E.BVMul n e1 e2), smulOverflow n e1 e2)
(M.Div, Just M.Unsigned) ->
return (MirExp (C.BVRepr n) (S.app $ E.BVUdiv n e1 e2), udivOverflow n e1 e2)
(M.Div, Just M.Signed) ->
return (MirExp (C.BVRepr n) (S.app $ E.BVSdiv n e1 e2), sdivOverflow n e1 e2)
(M.Rem, Just M.Unsigned) ->
return (MirExp (C.BVRepr n) (S.app $ E.BVUrem n e1 e2), udivOverflow n e1 e2)
(M.Rem, Just M.Signed) ->
return (MirExp (C.BVRepr n) (S.app $ E.BVSrem n e1 e2), sdivOverflow n e1 e2)
-- Bitwise ops never overflow
(M.BitXor, _) -> return (MirExp (C.BVRepr n) (S.app $ E.BVXor n e1 e2), noOverflow)
(M.BitAnd, _) -> return (MirExp (C.BVRepr n) (S.app $ E.BVAnd n e1 e2), noOverflow)
(M.BitOr, _) -> return (MirExp (C.BVRepr n) (S.app $ E.BVOr n e1 e2), noOverflow)
-- Shift ops overflow when shift amount >= bit width
-- If `extendToMax` padded the first argument, we need to
-- truncate the result back down to its original width using
-- `extendUnsignedBV`.
--
-- TODO: clean this up so it's more precise about how the
-- operands get extended/truncated, instead of using the somewhat
-- magical `extendToMax` / `extendUnsignedBV` functions.
(M.Shl, _) -> do
res <- extendUnsignedBV (MirExp (C.BVRepr n) (S.app $ E.BVShl n e1 e2)) na
return (res, shiftOverflowBV na ma e2a)
(M.Shr, Just M.Unsigned) -> do
res <- extendUnsignedBV (MirExp (C.BVRepr n) (S.app $ E.BVLshr n e1 e2)) na
return (res, shiftOverflowBV na ma e2a)
(M.Shr, Nothing) -> do
res <- extendUnsignedBV (MirExp (C.BVRepr n) (S.app $ E.BVLshr n e1 e2)) na
return (res, shiftOverflowBV na ma e2a)
(M.Shr, Just M.Signed) -> do
res <- extendSignedBV (MirExp (C.BVRepr n) (S.app $ E.BVAshr n e1 e2) ) na
return (res, shiftOverflowBV na ma e2a)
-- Comparison ops never overflow
(M.Lt, Just M.Unsigned) -> return (MirExp (C.BoolRepr) (S.app $ E.BVUlt n e1 e2), noOverflow)
(M.Lt, Just M.Signed) -> return (MirExp (C.BoolRepr) (S.app $ E.BVSlt n e1 e2), noOverflow)
(M.Le, Just M.Unsigned) -> return (MirExp (C.BoolRepr) (S.app $ E.BVUle n e1 e2), noOverflow)
(M.Le, Just M.Signed) -> return (MirExp (C.BoolRepr) (S.app $ E.BVSle n e1 e2), noOverflow)
(M.Gt, Just M.Unsigned) -> return (MirExp (C.BoolRepr) (S.app $ E.BVUlt n e2 e1), noOverflow)
(M.Gt, Just M.Signed) -> return (MirExp (C.BoolRepr) (S.app $ E.BVSlt n e2 e1), noOverflow)
(M.Ge, Just M.Unsigned) -> return (MirExp (C.BoolRepr) (S.app $ E.BVUle n e2 e1), noOverflow)
(M.Ge, Just M.Signed) -> return (MirExp (C.BoolRepr) (S.app $ E.BVSle n e2 e1), noOverflow)
(M.Ne, _) -> return (MirExp (C.BoolRepr) (S.app $ E.Not $ S.app $ E.BVEq n e1 e2), noOverflow)
(M.Beq, _) -> return (MirExp (C.BoolRepr) (S.app $ E.BVEq n e1 e2), noOverflow)
_ -> mirFail $ "No translation for binop: " ++ show bop ++ " " ++ show mat
++ " for " ++ show ty1 ++ " and " ++ show ty2
(MirExp C.BoolRepr e1, MirExp C.BoolRepr e2) ->
case bop of
M.BitAnd -> return (MirExp C.BoolRepr (S.app $ E.And e1 e2), noOverflow)
M.BitXor -> return (MirExp C.BoolRepr (S.app $ E.BoolXor e1 e2), noOverflow)
M.BitOr -> return (MirExp C.BoolRepr (S.app $ E.Or e1 e2), noOverflow)
M.Beq -> return (MirExp C.BoolRepr (S.app $ E.Not $ S.app $ E.BoolXor e1 e2), noOverflow)
M.Ne -> return (MirExp C.BoolRepr (S.app $ E.BoolXor e1 e2), noOverflow)
_ -> mirFail $ "No translation for bool binop: " ++ fmt bop
(MirExp C.RealValRepr e1, MirExp C.RealValRepr e2) ->
case bop of
M.Beq -> return (MirExp C.BoolRepr (S.app $ E.RealEq e1 e2), noOverflow)
M.Lt -> return (MirExp C.BoolRepr (S.app $ E.RealLt e1 e2), noOverflow)
M.Le -> return (MirExp C.BoolRepr (S.app $ E.RealLe e1 e2), noOverflow)
M.Gt -> return (MirExp C.BoolRepr (S.app $ E.RealLt e2 e1), noOverflow)
M.Ge -> return (MirExp C.BoolRepr (S.app $ E.RealLe e2 e1), noOverflow)
M.Ne -> return (MirExp C.BoolRepr (S.app $ E.Not $ S.app $ E.RealEq e1 e2), noOverflow)
-- Binops on floats never set the overflow flag
M.Add -> return (MirExp C.RealValRepr (S.app $ E.RealAdd e1 e2), noOverflow)
M.Sub -> return (MirExp C.RealValRepr (S.app $ E.RealSub e1 e2), noOverflow)
M.Mul -> return (MirExp C.RealValRepr (S.app $ E.RealMul e1 e2), noOverflow)
M.Div -> return (MirExp C.RealValRepr (S.app $ E.RealDiv e1 e2), noOverflow)
M.Rem -> return (MirExp C.RealValRepr (S.app $ E.RealMod e1 e2), noOverflow)
_ -> mirFail $ "No translation for real number binop: " ++ fmt bop
(MirExp MirReferenceRepr e1, MirExp MirReferenceRepr e2) ->
case bop of
M.Beq -> do
eq <- mirRef_eq e1 e2
return (MirExp C.BoolRepr eq, noOverflow)
M.Ne -> do
eq <- mirRef_eq e1 e2
return (MirExp C.BoolRepr $ S.app $ E.Not eq, noOverflow)
_ -> mirFail $ "No translation for pointer binop: " ++ fmt bop
(MirExp MirReferenceRepr e1, MirExp UsizeRepr e2) -> do
newRef <- mirRef_offsetWrap e1 e2
return (MirExp MirReferenceRepr newRef, noOverflow)
(_, _) -> mirFail $ "bad or unimplemented type: " ++ (fmt bop) ++ ", " ++ (show me1) ++ ", " ++ (show me2)
where
noOverflow :: R.Expr MIR s C.BoolType
noOverflow = S.app $ E.BoolLit False
-- Check whether unsigned multiplication of `e1 * e2` overflows `w` bits.
-- If `zext e1 * zext e2 /= zext (e1 * e2)`, then overflow has occurred.
mulOverflow :: forall w. (1 <= w, 1 <= w + w) =>
NatRepr w ->
(R.Expr MIR s (C.BVType w) -> R.Expr MIR s (C.BVType (w + w))) ->
R.Expr MIR s (C.BVType w) ->
R.Expr MIR s (C.BVType w) ->
R.Expr MIR s C.BoolType
mulOverflow w ext e1 e2 = S.app $ E.Not $ S.app $ E.BVEq w'
(S.app $ E.BVMul w' (ext e1) (ext e2))
(ext $ S.app $ E.BVMul w e1 e2)
where w' = addNat w w
umulOverflow :: forall w. (1 <= w) =>
NatRepr w -> R.Expr MIR s (C.BVType w) -> R.Expr MIR s (C.BVType w) ->
R.Expr MIR s C.BoolType
umulOverflow w e1 e2
| LeqProof <- leqAdd2 (leqRefl w) (LeqProof @1 @w),
LeqProof <- dblPosIsPos (LeqProof @1 @w) =
mulOverflow w (S.app . E.BVZext (addNat w w) w) e1 e2
smulOverflow :: forall w. (1 <= w) =>
NatRepr w -> R.Expr MIR s (C.BVType w) -> R.Expr MIR s (C.BVType w) ->
R.Expr MIR s C.BoolType
smulOverflow w e1 e2
| LeqProof <- leqAdd2 (leqRefl w) (LeqProof @1 @w),
LeqProof <- dblPosIsPos (LeqProof @1 @w) =
mulOverflow w (S.app . E.BVSext (addNat w w) w) e1 e2
-- Check that shift amount `e` is less than the input width `w`.
shiftOverflowNat w e =
let wLit = S.app $ E.NatLit $ natValue w
in S.app $ E.Not $ S.app $ E.NatLt e wLit
-- Check that shift amount `e` (whose width in `w'`) is less than the input
-- width `w`.
shiftOverflowBV :: (1 <= w') =>
NatRepr w -> NatRepr w' -> R.Expr MIR s (C.BVType w') -> R.Expr MIR s C.BoolType
shiftOverflowBV w w' e =
let wLit = S.app $ eBVLit w' $ intValue w
in S.app $ E.Not $ S.app $ E.BVUlt w' e wLit
udivOverflow :: (1 <= w) =>
NatRepr w ->
R.Expr MIR s (C.BVType w) ->
R.Expr MIR s (C.BVType w) ->
R.Expr MIR s C.BoolType
udivOverflow w _x y = S.app $ E.BVEq w y $ S.app $ eBVLit w 0
sdivOverflow :: (1 <= w) =>
NatRepr w ->
R.Expr MIR s (C.BVType w) ->
R.Expr MIR s (C.BVType w) ->
R.Expr MIR s C.BoolType
sdivOverflow w x y =
S.app $ E.Or (udivOverflow w x y) $
-- Are we dividing INT_MIN by -1? E.g. `x == -128 && y == -1`
S.app $ E.And
(S.app $ E.BVEq w x $ S.app $ eBVLit w (1 `shiftL` (w' - 1)))
(S.app $ E.BVEq w y $ S.app $ eBVLit w ((1 `shiftL` w') - 1))
where w' = fromIntegral $ intValue w
-- Nullary ops in rust are used for resource allocation, so are not interpreted
transNullaryOp :: M.NullOp -> M.Ty -> MirGenerator h s ret (MirExp s)
transNullaryOp nop ty =
case nop of
M.AlignOf -> getLayoutFieldAsMirExp "AlignOf" layAlign ty
M.SizeOf -> getLayoutFieldAsMirExp "SizeOf" laySize ty
M.UbChecks -> do
-- Disable undefined behavior checks.
-- TODO: re-enable this later, and fix the tests that break
-- (see https://github.com/GaloisInc/mir-json/issues/107)
return $ MirExp C.BoolRepr $ R.App $ E.BoolLit False
transUnaryOp :: M.UnOp -> M.Operand -> MirGenerator h s ret (MirExp s)
transUnaryOp uop op = do
mop <- evalOperand op
case (uop, mop) of
(M.Not, MirExp C.BoolRepr e) -> return $ MirExp C.BoolRepr $ S.app $ E.Not e
(M.Not, MirExp (C.BVRepr n) e) -> return $ MirExp (C.BVRepr n) $ S.app $ E.BVNot n e
(M.Neg, MirExp (C.BVRepr n) e) -> return $ MirExp (C.BVRepr n) (S.app $ E.BVSub n (S.app $ eBVLit n 0) e)
(M.Neg, MirExp C.IntegerRepr e) -> return $ MirExp C.IntegerRepr $ S.app $ E.IntNeg e
(M.Neg, MirExp C.RealValRepr e) -> return $ MirExp C.RealValRepr $ S.app $ E.RealNeg e
(M.PtrMetadata, MirExp MirSliceRepr e) -> return $ MirExp UsizeRepr $ getSliceLen e
(_ , MirExp ty _) -> mirFail $ "Unimplemented unary op `" ++ fmt uop ++ "' for " ++ show ty
-- a -> u -> [a;u]
buildRepeat :: M.Operand -> M.ConstUsize -> MirGenerator h s ret (MirExp s)
buildRepeat op size = do
MirExp tpr e <- evalOperand op
let n = fromInteger size
-- TODO: hardcoded size=1
ag <- mirAggregate_uninit_constSize n
ag' <- foldM
(\ag' i -> mirAggregate_set i 1 tpr e ag')
ag (init [0 .. n])
return $ MirExp MirAggregateRepr ag'
-- casts
-- | Make sure that the expression has exactly the bitwidth requested. If the BV is too short, extend. If too long, truncate.
extendUnsignedBV :: (1 <= w) => MirExp s -> NatRepr w -> MirGenerator h s ret (MirExp s)
extendUnsignedBV (MirExp tp e) w =
case tp of
(C.BVRepr n) | Just Refl <- testEquality w n ->
return $ MirExp tp e
(C.BVRepr n) | Just LeqProof <- testLeq (incNat w) n ->
return $ MirExp (C.BVRepr w) (S.app $ E.BVTrunc w n e)
(C.BVRepr n) | Just LeqProof <- testLeq (incNat n) w ->
return $ MirExp (C.BVRepr w) (S.app $ E.BVZext w n e)
_ -> mirFail ("unimplemented unsigned bvext: " ++ show tp ++ " " ++ show w)
extendSignedBV :: (1 <= w) => MirExp s -> NatRepr w -> MirGenerator h s ret (MirExp s)
extendSignedBV (MirExp tp e) w =
case tp of
(C.BVRepr n) | Just Refl <- testEquality w n ->
return $ MirExp tp e
(C.BVRepr n) | Just LeqProof <- testLeq (incNat w) n ->
return $ MirExp (C.BVRepr w) (S.app $ E.BVTrunc w n e)
(C.BVRepr n) | Just LeqProof <- testLeq (incNat n) w ->
return $ MirExp (C.BVRepr w) (S.app $ E.BVSext w n e)
_ -> mirFail $ "unimplemented signed bvext " ++ show tp ++ " " ++ show w
evalCast' :: forall h s ret. HasCallStack => M.CastKind -> M.Ty -> MirExp s -> M.Ty -> MirGenerator h s ret (MirExp s)
evalCast' ck ty1 e ty2 = do
col <- use $ cs . collection
case (ck, ty1, ty2) of
(M.Misc,a,b) | a == b -> return e
(M.Misc, M.TyUint M.USize, M.TyInt M.USize)
| MirExp UsizeRepr e0 <- e
-> return $ MirExp IsizeRepr (usizeToIsize R.App e0)
(M.Misc, M.TyInt M.USize, M.TyUint M.USize)
| MirExp IsizeRepr e0 <- e
-> return $ MirExp UsizeRepr (isizeToUsize R.App e0)
(M.Misc, M.TyUint _, M.TyInt M.USize)
| MirExp (C.BVRepr sz) e0 <- e
-> return $ MirExp IsizeRepr (bvToIsize sz R.App e0)
(M.Misc, M.TyUint _, M.TyUint M.USize)
| MirExp (C.BVRepr sz) e0 <- e
-> return $ MirExp UsizeRepr (bvToUsize sz R.App e0)
(M.Misc, M.TyInt _, M.TyInt M.USize)
| MirExp (C.BVRepr sz) e0 <- e
-> return $ MirExp IsizeRepr (sbvToIsize sz R.App e0)
(M.Misc, M.TyInt _, M.TyUint M.USize)
| MirExp (C.BVRepr sz) e0 <- e
-> return $ MirExp UsizeRepr (sbvToUsize sz R.App e0)
(M.Misc, M.TyUint M.USize, M.TyUint bsz)
| MirExp UsizeRepr e0 <- e
-> baseSizeToNatCont bsz $ \w -> return $
MirExp (C.BVRepr w) (usizeToBv w R.App e0)
(M.Misc, M.TyInt M.USize, M.TyUint bsz)
| MirExp IsizeRepr e0 <- e
-> baseSizeToNatCont bsz $ \w -> return $
MirExp (C.BVRepr w) (isizeToBv w R.App e0)
(M.Misc, M.TyUint M.USize, M.TyInt bsz)
| MirExp UsizeRepr e0 <- e
-> baseSizeToNatCont bsz $ \w -> return $
MirExp (C.BVRepr w) (usizeToBv w R.App e0)
(M.Misc, M.TyInt M.USize, M.TyInt bsz)
| MirExp IsizeRepr e0 <- e
-> baseSizeToNatCont bsz $ \w -> return $
MirExp (C.BVRepr w) (isizeToBv w R.App e0)
(M.Misc, M.TyUint _, M.TyUint s) -> baseSizeToNatCont s $ extendUnsignedBV e
(M.Misc, M.TyInt _, M.TyInt s) -> baseSizeToNatCont s $ extendSignedBV e
-- unsigned to signed (nothing to do except fix sizes)
(M.Misc, M.TyUint _, M.TyInt s) -> baseSizeToNatCont s $ extendUnsignedBV e
-- signed to unsigned. Testing indicates that this sign-extends.
(M.Misc, M.TyInt _, M.TyUint s) -> baseSizeToNatCont s $ extendSignedBV e
-- boolean to nat
(M.Misc, TyBool, TyUint M.USize)
| MirExp C.BoolRepr e0 <- e
-> return $ MirExp UsizeRepr (R.App $ usizeIte e0 (R.App $ usizeLit 1) (R.App $ usizeLit 0))
(M.Misc, TyBool, TyInt M.USize)
-- boolean to integer
| MirExp C.BoolRepr e0 <- e
-> return $ MirExp IsizeRepr (R.App $ isizeIte e0 (R.App $ isizeLit 1) (R.App $ isizeLit 0))
-- booleans to BVs
(M.Misc, TyBool, TyUint bsz)
| MirExp C.BoolRepr e0 <- e
-> baseSizeToNatCont bsz $ \w ->
return $ MirExp (C.BVRepr w) (R.App $ E.BVIte e0 w (R.App $ eBVLit w 1) (R.App $ eBVLit w 0))
(M.Misc, TyBool, TyInt bsz)
| MirExp C.BoolRepr e0 <- e
-> baseSizeToNatCont bsz $ \w ->
return $ MirExp (C.BVRepr w) (R.App $ E.BVIte e0 w (R.App $ eBVLit w 1) (R.App $ eBVLit w 0))
-- char to usize
(M.Misc, M.TyChar, M.TyUint M.USize)
| MirExp (C.BVRepr sz) e0 <- e
-> return $ MirExp UsizeRepr (bvToUsize sz R.App e0)
-- char to other uint
(M.Misc, M.TyChar, M.TyUint s) -> baseSizeToNatCont s $ extendUnsignedBV e
-- byte to char
(M.Misc, M.TyUint B8, M.TyChar) -> baseSizeToNatCont M.B32 $ extendUnsignedBV e
{- -- BV to Float
(M.Misc, M.TyInt bsz, TyFloat fsz)
| MirExp (C.BVRepr sz) e0 <- e
-> return $ MirExp C.FloatRepr -}
-- Not sure why this appears in generated MIR, but libcore has some no-op
-- unsizes from `*const dyn Any` to `*const dyn Any`
-- TODO: Remove this completely.
(M.Unsize,a,b) | a == b -> return e
-- ADT -> ADT unsizing is done via `CoerceUnsized`, and handled here.
-- Reference-to-ADT -> reference-to-ADT casting is handled separately,
-- below.
(M.Unsize, M.TyAdt aname1 _ _, M.TyAdt aname2 _ _) ->
coerceUnsized ck aname1 aname2 e
(M.UnsizeVtable _, M.TyAdt aname1 _ _, M.TyAdt aname2 _ _) ->
coerceUnsized ck aname1 aname2 e
(M.Unsize, M.TyRef (M.TyArray tp sz) _, M.TyRef (M.TySlice tp') _) ->
unsizeArray tp sz tp'
(M.Unsize, M.TyRawPtr (M.TyArray tp sz) _, M.TyRawPtr (M.TySlice tp') _) ->
unsizeArray tp sz tp'
-- Trait object creation from a ref
(M.UnsizeVtable vtbl, M.TyRef _ _,
M.TyRef (M.TyDynamic traitName') _) ->
mkTraitObject traitName' vtbl e
(M.UnsizeVtable vtbl, M.TyRawPtr _ _,
M.TyRawPtr (M.TyDynamic traitName') _) ->
mkTraitObject traitName' vtbl e
-- Casting between TyDynamics that vary only in their auto traits
-- TODO: this should also normalize the TraitProjection predicates, to
-- allow casting between equivalent descriptions of the same trait object
(M.Unsize, M.TyRef (M.TyDynamic t1) _, M.TyRef (M.TyDynamic t2) _)
| t1 == t2
-> return e
(M.Unsize, M.TyRef _ _, M.TyRef (M.TyDynamic _) _) ->
mirFail $ unlines $
[ "error when casting:"
, " ty: " <> show ty1
, " as: " <> show ty2
, "expected `UnsizeVtable` cast kind, but saw `Unsize` cast kind" ]
(M.Unsize, M.TyRawPtr _ _, M.TyRawPtr (M.TyDynamic _) _) ->
mirFail $ unlines $
[ "error when casting:"
, " ty: " <> show ty1
, " as: " <> show ty2
, "expected `UnsizeVtable` cast kind, but saw `Unsize` cast kind" ]
-- trait object cast down to underlying object reference (forgetting vtable)
(M.Misc, M.TyRawPtr (M.TyDynamic _) _, M.TyRawPtr _ _)
| Right (Some MirReferenceRepr) <- tyToRepr col ty2
, MirExp DynRefRepr a <- e
-> pure (MirExp MirReferenceRepr (R.App (E.GetStruct a dynRefDataIndex MirReferenceRepr)))
-- Unsized casts from references to sized structs to references to DSTs.
-- We defer to the provided cast kind to determine what kind of unsizing
-- cast we expect to perform, i.e. what kind of metadata to include in the
-- created fat pointer.
(M.Unsize, M.TyRef (M.TyAdt an1 _ _) m1, M.TyRef (M.TyAdt an2 _ _) m2) ->
unsizeAdtSlice M.TyRef an1 m1 an2 m2
(M.Unsize, M.TyRawPtr (M.TyAdt an1 _ _) m1, M.TyRawPtr (M.TyAdt an2 _ _) m2) ->
unsizeAdtSlice M.TyRawPtr an1 m1 an2 m2
(M.UnsizeVtable vtable, M.TyRef (M.TyAdt an1 _ _) m1, M.TyRef (M.TyAdt an2 _ _) m2) ->
unsizeAdtDyn vtable M.TyRef an1 m1 an2 m2
(M.UnsizeVtable vtable, M.TyRawPtr (M.TyAdt an1 _ _) m1, M.TyRawPtr (M.TyAdt an2 _ _) m2) ->
unsizeAdtDyn vtable M.TyRawPtr an1 m1 an2 m2
-- C-style adts, casting an enum value to a TyInt
(M.Misc, M.TyAdt aname _ _, M.TyInt sz) -> do
adt <- findAdt aname
discr <- enumDiscriminant adt e
evalCast' M.Misc (M.TyInt M.USize) discr (M.TyInt sz)
(M.Misc, M.TyAdt aname _ _, M.TyUint sz) -> do
adt <- findAdt aname
discr <- enumDiscriminant adt e
evalCast' M.Misc (M.TyInt M.USize) discr (M.TyUint sz)
-- References have the same representation as Raw pointers
(M.Misc, M.TyRef ty1' mut1, M.TyRawPtr ty2' mut2)
| ty1' == ty2' && mut1 == mut2 -> return e
(M.MutToConstPointer, M.TyRawPtr ty1' M.Mut, M.TyRawPtr ty2' M.Immut)
| ty1' == ty2' -> return e
-- Integer-to-pointer casts. Pointer-to-integer casts are not yet
-- supported.
(M.Misc, M.TyInt _, M.TyRawPtr _ _) -> transmuteExp e ty1 ty2
(M.Misc, M.TyUint _, M.TyRawPtr _ _) -> transmuteExp e ty1 ty2
-- *const [T] -> *T (discards the length and returns only the pointer)
(M.Misc, M.TyRawPtr (M.TySlice t1) m1, M.TyRawPtr t2 m2)
| t1 == t2, m1 == m2, MirExp MirSliceRepr e' <- e
-> return $ MirExp MirReferenceRepr (getSlicePtr e')
(M.Misc, M.TyRawPtr M.TyStr m1, M.TyRawPtr (M.TyUint M.B8) m2)
| m1 == m2, MirExp MirSliceRepr e' <- e
-> return $ MirExp MirReferenceRepr (getSlicePtr e')
-- *const [T; N] -> *const T (get first element)
(M.Misc, M.TyRawPtr (M.TyArray t1 _) m1, M.TyRawPtr t2 m2)
| t1 == t2, m1 == m2, MirExp MirReferenceRepr e' <- e
-> do
Some tpr <- tyToReprM t1
MirExp MirReferenceRepr <$> subindexRef tpr e' (R.App $ usizeLit 0)
-- *const [u8] <-> *const str (no-ops)
(M.Misc, M.TyRawPtr (M.TySlice (M.TyUint M.B8)) m1, M.TyRawPtr M.TyStr m2)
| m1 == m2 -> return e
(M.Misc, M.TyRawPtr M.TyStr m1, M.TyRawPtr (M.TySlice (M.TyUint M.B8)) m2)
| m1 == m2 -> return e
-- Arbitrary pointer-to-pointer casts are allowed as long as the source
-- and destination types have the same Crucible representation. This is
-- similar to calling `transmute`.
(M.Misc, M.TyRawPtr _ _, M.TyRawPtr _ _)
| ty1 == ty2 -> return e
| tyToRepr col ty1 == tyToRepr col ty2 -> return e
(M.ReifyFnPointer, M.TyFnDef defId, M.TyFnPtr sig)
-> do mhand <- lookupFunction defId
case mhand of
Just (me, sig')
| sig == sig' -> return me
| otherwise -> mirFail $
"ReifyFnPointer: bad MIR: method handle has wrong sig: " ++
show (defId, sig, sig')
Nothing -> mirFail $
"ReifyFnPointer: bad MIR: can't find method handle: " ++
show defId
(M.ClosureFnPointer shimDefId, M.TyClosure [], M.TyFnPtr sig)
-> do mhand <- lookupFunction shimDefId
case mhand of
Just (me, sig')
| sig == sig' -> return me
| otherwise -> mirFail $
"ClosureFnPointer: bad MIR: method handle has wrong sig: " ++
show (shimDefId, sig, sig')
Nothing -> mirFail $
"ClosureFnPointer: bad MIR: can't find method handle: " ++
show shimDefId
(M.Transmute, _, _) -> transmuteExp e ty1 ty2
-- This casts from a safe pointer to an unsafe one.
-- Since we don't track safeness this is just a no-op for now, but if
-- we decide to track that, this needs to be updated.
(M.UnsafeFnPointer, _, _) | ty1 == ty2 -> pure e
_ -> mirFail $ "unimplemented cast: " ++ (show ck) ++
"\n ty: " ++ (show ty1) ++ "\n as: " ++ (show ty2)
where
-- | Attempt to access the repr(transparent) field types of the two structs,
-- failing if only one is repr(transparent)
reprTransparentFieldTys :: AdtName -> AdtName -> MirGenerator h s ret (Maybe (Ty, Ty))
reprTransparentFieldTys an1 an2 = do
col <- use $ cs . collection
adt1 <- findAdt an1
adt2 <- findAdt an2
case (reprTransparentFieldTy col adt1, reprTransparentFieldTy col adt2) of
(Just field1Ty, Just field2Ty) ->
pure $ Just (field1Ty, field2Ty)
(Nothing, Nothing) ->
pure Nothing
(Just _, Nothing) ->